utils/arg_helper.cmo : utils/arg_helper.cmi
utils/arg_helper.cmx : utils/arg_helper.cmi
utils/arg_helper.cmi :
+utils/build_path_prefix_map.cmo : utils/build_path_prefix_map.cmi
+utils/build_path_prefix_map.cmx : utils/build_path_prefix_map.cmi
+utils/build_path_prefix_map.cmi :
utils/ccomp.cmo : utils/misc.cmi utils/config.cmi utils/clflags.cmi \
utils/ccomp.cmi
utils/ccomp.cmx : utils/misc.cmx utils/config.cmx utils/clflags.cmx \
parsing/location.cmx parsing/docstrings.cmx parsing/lexer.cmi
parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi
parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi utils/misc.cmi \
- utils/clflags.cmi parsing/location.cmi
+ utils/clflags.cmi utils/build_path_prefix_map.cmi parsing/location.cmi
parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx utils/misc.cmx \
- utils/clflags.cmx parsing/location.cmi
+ utils/clflags.cmx utils/build_path_prefix_map.cmx parsing/location.cmi
parsing/location.cmi : utils/warnings.cmi
parsing/longident.cmo : utils/misc.cmi parsing/longident.cmi
parsing/longident.cmx : utils/misc.cmx parsing/longident.cmi
typing/cmi_format.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \
typing/btype.cmx parsing/asttypes.cmi typing/env.cmi
typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \
- typing/path.cmi parsing/longident.cmi parsing/location.cmi \
+ typing/path.cmi utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi utils/consistbl.cmi typing/cmi_format.cmi \
parsing/asttypes.cmi
typing/envaux.cmo : typing/subst.cmi typing/printtyp.cmi typing/path.cmi \
- typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/envaux.cmi
+ typing/ident.cmi typing/env.cmi typing/envaux.cmi
typing/envaux.cmx : typing/subst.cmx typing/printtyp.cmx typing/path.cmx \
- typing/ident.cmx typing/env.cmx parsing/asttypes.cmi typing/envaux.cmi
+ typing/ident.cmx typing/env.cmx typing/envaux.cmi
typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi
-typing/ident.cmo : utils/identifiable.cmi typing/ident.cmi
-typing/ident.cmx : utils/identifiable.cmx typing/ident.cmi
+typing/ident.cmo : utils/identifiable.cmi utils/clflags.cmi typing/ident.cmi
+typing/ident.cmx : utils/identifiable.cmx utils/clflags.cmx typing/ident.cmi
typing/ident.cmi : utils/identifiable.cmi
typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \
typing/path.cmi typing/ctype.cmi parsing/builtin_attributes.cmi \
typing/outcometree.cmi : parsing/asttypes.cmi
typing/parmatch.cmo : utils/warnings.cmi typing/untypeast.cmi \
typing/types.cmi typing/typedtreeIter.cmi typing/typedtree.cmi \
- typing/subst.cmi typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \
- utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
- typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \
- typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
- typing/parmatch.cmi
+ typing/subst.cmi typing/printpat.cmi typing/predef.cmi typing/path.cmi \
+ parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
+ parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
+ utils/config.cmi typing/btype.cmi parsing/asttypes.cmi \
+ parsing/ast_helper.cmi typing/parmatch.cmi
typing/parmatch.cmx : utils/warnings.cmx typing/untypeast.cmx \
typing/types.cmx typing/typedtreeIter.cmx typing/typedtree.cmx \
- typing/subst.cmx typing/predef.cmx typing/path.cmx parsing/parsetree.cmi \
- utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
- typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
- typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
- typing/parmatch.cmi
+ typing/subst.cmx typing/printpat.cmx typing/predef.cmx typing/path.cmx \
+ parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \
+ parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
+ utils/config.cmx typing/btype.cmx parsing/asttypes.cmi \
+ parsing/ast_helper.cmx typing/parmatch.cmi
typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi \
- parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
- typing/env.cmi parsing/asttypes.cmi
+ parsing/parsetree.cmi parsing/location.cmi typing/env.cmi \
+ parsing/asttypes.cmi
typing/path.cmo : typing/ident.cmi typing/path.cmi
typing/path.cmx : typing/ident.cmx typing/path.cmi
typing/path.cmi : typing/ident.cmi
typing/primitive.cmi
typing/primitive.cmi : parsing/parsetree.cmi typing/outcometree.cmi \
parsing/location.cmi
+typing/printpat.cmo : typing/types.cmi typing/typedtree.cmi typing/ident.cmi \
+ parsing/asttypes.cmi typing/printpat.cmi
+typing/printpat.cmx : typing/types.cmx typing/typedtree.cmx typing/ident.cmx \
+ parsing/asttypes.cmi typing/printpat.cmi
+typing/printpat.cmi : typing/typedtree.cmi parsing/asttypes.cmi
typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \
typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \
typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi \
typing/typecore.cmo : utils/warnings.cmi typing/typetexp.cmi \
typing/types.cmi typing/typeopt.cmi typing/typedtree.cmi \
typing/typedecl.cmi typing/subst.cmi typing/stypes.cmi \
- typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
- typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi \
- typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
- parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
- typing/cmt_format.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \
- typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
- typing/annot.cmi typing/typecore.cmi
+ typing/printtyp.cmi typing/printpat.cmi typing/primitive.cmi \
+ typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \
+ typing/parmatch.cmi typing/oprint.cmi typing/mtype.cmi utils/misc.cmi \
+ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
+ typing/env.cmi typing/ctype.cmi utils/config.cmi typing/cmt_format.cmi \
+ utils/clflags.cmi parsing/builtin_attributes.cmi typing/btype.cmi \
+ parsing/asttypes.cmi parsing/ast_helper.cmi typing/annot.cmi \
+ typing/typecore.cmi
typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \
typing/types.cmx typing/typeopt.cmx typing/typedtree.cmx \
typing/typedecl.cmx typing/subst.cmx typing/stypes.cmx \
- typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
- typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \
- typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \
- parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
- typing/cmt_format.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \
- typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
- typing/annot.cmi typing/typecore.cmi
+ typing/printtyp.cmx typing/printpat.cmx typing/primitive.cmx \
+ typing/predef.cmx typing/path.cmx parsing/parsetree.cmi \
+ typing/parmatch.cmx typing/oprint.cmx typing/mtype.cmx utils/misc.cmx \
+ parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
+ typing/env.cmx typing/ctype.cmx utils/config.cmx typing/cmt_format.cmx \
+ utils/clflags.cmx parsing/builtin_attributes.cmx typing/btype.cmx \
+ parsing/asttypes.cmi parsing/ast_helper.cmx typing/annot.cmi \
+ typing/typecore.cmi
typing/typecore.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi
parsing/location.cmi typing/includemod.cmi typing/ident.cmi \
typing/env.cmi typing/ctype.cmi utils/config.cmi typing/cmt_format.cmi \
typing/cmi_format.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \
- typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi typing/typemod.cmi
+ typing/btype.cmi parsing/attr_helper.cmi parsing/asttypes.cmi \
+ typing/annot.cmi typing/typemod.cmi
typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \
typing/typeclass.cmx typing/subst.cmx typing/stypes.cmx \
parsing/location.cmx typing/includemod.cmx typing/ident.cmx \
typing/env.cmx typing/ctype.cmx utils/config.cmx typing/cmt_format.cmx \
typing/cmi_format.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \
- typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi typing/typemod.cmi
+ typing/btype.cmx parsing/attr_helper.cmx parsing/asttypes.cmi \
+ typing/annot.cmi typing/typemod.cmi
typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi typing/includemod.cmi typing/ident.cmi \
typing/typetexp.cmo : typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \
typing/printtyp.cmi typing/predef.cmi typing/path.cmi \
parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
- parsing/location.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \
- parsing/builtin_attributes.cmi typing/btype.cmi parsing/asttypes.cmi \
- parsing/ast_helper.cmi typing/typetexp.cmi
+ parsing/location.cmi typing/includemod.cmi typing/env.cmi \
+ typing/ctype.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \
+ typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
+ typing/typetexp.cmi
typing/typetexp.cmx : typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \
typing/printtyp.cmx typing/predef.cmx typing/path.cmx \
parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \
- parsing/location.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \
- parsing/builtin_attributes.cmx typing/btype.cmx parsing/asttypes.cmi \
- parsing/ast_helper.cmx typing/typetexp.cmi
+ parsing/location.cmx typing/includemod.cmx typing/env.cmx \
+ typing/ctype.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \
+ typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
+ typing/typetexp.cmi
typing/typetexp.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
- typing/env.cmi parsing/asttypes.cmi
+ typing/includemod.cmi typing/env.cmi parsing/asttypes.cmi
typing/untypeast.cmo : typing/typedtree.cmi typing/path.cmi \
parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi \
bytecomp/bytelibrarian.cmi :
bytecomp/bytelink.cmo : utils/warnings.cmi bytecomp/symtable.cmi \
bytecomp/opcodes.cmo utils/misc.cmi parsing/location.cmi \
- bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \
- bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \
- utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \
- utils/ccomp.cmi bytecomp/bytesections.cmi bytecomp/bytelink.cmi
+ bytecomp/instruct.cmi typing/ident.cmi bytecomp/emitcode.cmi \
+ bytecomp/dll.cmi utils/consistbl.cmi utils/config.cmi \
+ bytecomp/cmo_format.cmi utils/clflags.cmi utils/ccomp.cmi \
+ bytecomp/bytesections.cmi bytecomp/bytelink.cmi
bytecomp/bytelink.cmx : utils/warnings.cmx bytecomp/symtable.cmx \
bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx \
- bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \
- bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \
- utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \
- utils/ccomp.cmx bytecomp/bytesections.cmx bytecomp/bytelink.cmi
+ bytecomp/instruct.cmx typing/ident.cmx bytecomp/emitcode.cmx \
+ bytecomp/dll.cmx utils/consistbl.cmx utils/config.cmx \
+ bytecomp/cmo_format.cmi utils/clflags.cmx utils/ccomp.cmx \
+ bytecomp/bytesections.cmx bytecomp/bytelink.cmi
bytecomp/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi
bytecomp/bytepackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \
typing/subst.cmi bytecomp/printlambda.cmi typing/path.cmi utils/misc.cmi \
bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \
parsing/location.cmi bytecomp/lambda.cmi bytecomp/instruct.cmi \
typing/ident.cmi typing/env.cmi utils/config.cmi bytecomp/cmo_format.cmi \
- utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
- bytecomp/emitcode.cmi
+ utils/clflags.cmi bytecomp/bytegen.cmi typing/btype.cmi \
+ parsing/asttypes.cmi bytecomp/emitcode.cmi
bytecomp/emitcode.cmx : bytecomp/translmod.cmx typing/primitive.cmx \
bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx \
parsing/location.cmx bytecomp/lambda.cmx bytecomp/instruct.cmx \
typing/ident.cmx typing/env.cmx utils/config.cmx bytecomp/cmo_format.cmi \
- utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
- bytecomp/emitcode.cmi
+ utils/clflags.cmx bytecomp/bytegen.cmx typing/btype.cmx \
+ parsing/asttypes.cmi bytecomp/emitcode.cmi
bytecomp/emitcode.cmi : bytecomp/instruct.cmi typing/ident.cmi \
bytecomp/cmo_format.cmi
bytecomp/instruct.cmo : typing/types.cmi typing/subst.cmi \
bytecomp/lambda.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \
parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
bytecomp/matching.cmo : typing/types.cmi typing/typeopt.cmi \
- typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \
- typing/primitive.cmi typing/predef.cmi typing/path.cmi \
- typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \
+ typing/typedtree.cmi bytecomp/switch.cmi typing/printpat.cmi \
+ bytecomp/printlambda.cmi typing/primitive.cmi typing/predef.cmi \
+ typing/path.cmi typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
bytecomp/matching.cmi
bytecomp/matching.cmx : typing/types.cmx typing/typeopt.cmx \
- typing/typedtree.cmx bytecomp/switch.cmx bytecomp/printlambda.cmx \
- typing/primitive.cmx typing/predef.cmx typing/path.cmx \
- typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \
+ typing/typedtree.cmx bytecomp/switch.cmx typing/printpat.cmx \
+ bytecomp/printlambda.cmx typing/primitive.cmx typing/predef.cmx \
+ typing/path.cmx typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \
parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
bytecomp/matching.cmi
bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \
bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi
bytecomp/translcore.cmo : typing/types.cmi typing/typeopt.cmi \
- typing/typedtree.cmi typing/typecore.cmi bytecomp/translobj.cmi \
- bytecomp/translattribute.cmi typing/primitive.cmi typing/predef.cmi \
- typing/path.cmi typing/parmatch.cmi utils/misc.cmi bytecomp/matching.cmi \
+ typing/typedtree.cmi typing/typecore.cmi bytecomp/translprim.cmi \
+ bytecomp/translobj.cmi bytecomp/translattribute.cmi typing/printtyp.cmi \
+ typing/primitive.cmi typing/predef.cmi typing/path.cmi \
+ typing/parmatch.cmi utils/misc.cmi bytecomp/matching.cmi \
parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \
typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \
typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi
bytecomp/translcore.cmx : typing/types.cmx typing/typeopt.cmx \
- typing/typedtree.cmx typing/typecore.cmx bytecomp/translobj.cmx \
- bytecomp/translattribute.cmx typing/primitive.cmx typing/predef.cmx \
- typing/path.cmx typing/parmatch.cmx utils/misc.cmx bytecomp/matching.cmx \
+ typing/typedtree.cmx typing/typecore.cmx bytecomp/translprim.cmx \
+ bytecomp/translobj.cmx bytecomp/translattribute.cmx typing/printtyp.cmx \
+ typing/primitive.cmx typing/predef.cmx typing/path.cmx \
+ typing/parmatch.cmx utils/misc.cmx bytecomp/matching.cmx \
parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \
typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \
typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi
-bytecomp/translcore.cmi : typing/types.cmi typing/typedtree.cmi \
- typing/primitive.cmi typing/path.cmi parsing/location.cmi \
- bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
+bytecomp/translcore.cmi : typing/typedtree.cmi typing/path.cmi \
+ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
+ parsing/asttypes.cmi
bytecomp/translmod.cmo : typing/types.cmi typing/typedtree.cmi \
- bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \
- bytecomp/translattribute.cmi typing/printtyp.cmi typing/primitive.cmi \
- typing/predef.cmi typing/path.cmi typing/mtype.cmi utils/misc.cmi \
- parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \
- typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \
- parsing/asttypes.cmi bytecomp/translmod.cmi
+ bytecomp/translprim.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \
+ bytecomp/translclass.cmi bytecomp/translattribute.cmi typing/printtyp.cmi \
+ typing/primitive.cmi typing/predef.cmi typing/path.cmi typing/mtype.cmi \
+ utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
+ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
+ utils/clflags.cmi parsing/asttypes.cmi bytecomp/translmod.cmi
bytecomp/translmod.cmx : typing/types.cmx typing/typedtree.cmx \
- bytecomp/translobj.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \
- bytecomp/translattribute.cmx typing/printtyp.cmx typing/primitive.cmx \
- typing/predef.cmx typing/path.cmx typing/mtype.cmx utils/misc.cmx \
- parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \
- typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \
- parsing/asttypes.cmi bytecomp/translmod.cmi
+ bytecomp/translprim.cmx bytecomp/translobj.cmx bytecomp/translcore.cmx \
+ bytecomp/translclass.cmx bytecomp/translattribute.cmx typing/printtyp.cmx \
+ typing/primitive.cmx typing/predef.cmx typing/path.cmx typing/mtype.cmx \
+ utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
+ bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
+ utils/clflags.cmx parsing/asttypes.cmi bytecomp/translmod.cmi
bytecomp/translmod.cmi : typing/typedtree.cmi typing/primitive.cmi \
parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi
bytecomp/translobj.cmo : typing/primitive.cmi utils/misc.cmi \
typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \
typing/btype.cmx parsing/asttypes.cmi bytecomp/translobj.cmi
bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
+bytecomp/translprim.cmo : typing/types.cmi typing/typeopt.cmi \
+ typing/typedtree.cmi typing/primitive.cmi typing/predef.cmi \
+ typing/path.cmi utils/misc.cmi bytecomp/matching.cmi parsing/location.cmi \
+ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \
+ utils/clflags.cmi parsing/asttypes.cmi bytecomp/translprim.cmi
+bytecomp/translprim.cmx : typing/types.cmx typing/typeopt.cmx \
+ typing/typedtree.cmx typing/primitive.cmx typing/predef.cmx \
+ typing/path.cmx utils/misc.cmx bytecomp/matching.cmx parsing/location.cmx \
+ bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \
+ utils/clflags.cmx parsing/asttypes.cmi bytecomp/translprim.cmi
+bytecomp/translprim.cmi : typing/types.cmi typing/typedtree.cmi \
+ typing/primitive.cmi typing/path.cmi parsing/location.cmi \
+ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
asmcomp/CSE.cmo : asmcomp/mach.cmi asmcomp/CSEgen.cmi asmcomp/arch.cmo
asmcomp/CSE.cmx : asmcomp/mach.cmx asmcomp/CSEgen.cmx asmcomp/arch.cmx
asmcomp/CSEgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
asmcomp/asmlink.cmo : bytecomp/runtimedef.cmi utils/profile.cmi \
utils/misc.cmi parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \
utils/consistbl.cmi utils/config.cmi asmcomp/compilenv.cmi \
- asmcomp/cmx_format.cmi asmcomp/cmmgen.cmi utils/clflags.cmi \
- utils/ccomp.cmi asmcomp/asmgen.cmi asmcomp/asmlink.cmi
+ asmcomp/cmx_format.cmi asmcomp/cmmgen.cmi asmcomp/cmm.cmi \
+ utils/clflags.cmi utils/ccomp.cmi asmcomp/asmgen.cmi asmcomp/asmlink.cmi
asmcomp/asmlink.cmx : bytecomp/runtimedef.cmx utils/profile.cmx \
utils/misc.cmx parsing/location.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx \
utils/consistbl.cmx utils/config.cmx asmcomp/compilenv.cmx \
- asmcomp/cmx_format.cmi asmcomp/cmmgen.cmx utils/clflags.cmx \
- utils/ccomp.cmx asmcomp/asmgen.cmx asmcomp/asmlink.cmi
+ asmcomp/cmx_format.cmi asmcomp/cmmgen.cmx asmcomp/cmm.cmx \
+ utils/clflags.cmx utils/ccomp.cmx asmcomp/asmgen.cmx asmcomp/asmlink.cmi
asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi
asmcomp/asmpackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \
utils/profile.cmi utils/misc.cmi middle_end/middle_end.cmi \
asmcomp/arch.cmx
asmcomp/build_export_info.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/var_within_closure.cmi \
- middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
+ asmcomp/traverse_for_exported_symbols.cmi middle_end/base_types/tag.cmi \
+ middle_end/base_types/symbol.cmi middle_end/simple_value_approx.cmi \
middle_end/base_types/set_of_closures_id.cmi utils/misc.cmi \
- middle_end/invariant_params.cmi middle_end/flambda_utils.cmi \
- middle_end/flambda.cmi asmcomp/export_info.cmi \
+ middle_end/invariant_params.cmi middle_end/inline_and_simplify_aux.cmi \
+ middle_end/flambda_utils.cmi middle_end/flambda.cmi \
+ middle_end/find_recursive_functions.cmi asmcomp/export_info.cmi \
middle_end/base_types/export_id.cmi asmcomp/compilenv.cmi \
+ middle_end/base_types/compilation_unit.cmi \
middle_end/base_types/closure_id.cmi utils/clflags.cmi \
middle_end/backend_intf.cmi middle_end/allocated_const.cmi \
asmcomp/build_export_info.cmi
asmcomp/build_export_info.cmx : middle_end/base_types/variable.cmx \
middle_end/base_types/var_within_closure.cmx \
- middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \
+ asmcomp/traverse_for_exported_symbols.cmx middle_end/base_types/tag.cmx \
+ middle_end/base_types/symbol.cmx middle_end/simple_value_approx.cmx \
middle_end/base_types/set_of_closures_id.cmx utils/misc.cmx \
- middle_end/invariant_params.cmx middle_end/flambda_utils.cmx \
- middle_end/flambda.cmx asmcomp/export_info.cmx \
+ middle_end/invariant_params.cmx middle_end/inline_and_simplify_aux.cmx \
+ middle_end/flambda_utils.cmx middle_end/flambda.cmx \
+ middle_end/find_recursive_functions.cmx asmcomp/export_info.cmx \
middle_end/base_types/export_id.cmx asmcomp/compilenv.cmx \
+ middle_end/base_types/compilation_unit.cmx \
middle_end/base_types/closure_id.cmx utils/clflags.cmx \
middle_end/backend_intf.cmi middle_end/allocated_const.cmx \
asmcomp/build_export_info.cmi
asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi
asmcomp/closure_offsets.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/var_within_closure.cmi utils/misc.cmi \
- middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
- middle_end/flambda.cmi middle_end/base_types/closure_id.cmi \
- asmcomp/closure_offsets.cmi
+ middle_end/flambda_utils.cmi middle_end/flambda.cmi \
+ middle_end/base_types/closure_id.cmi asmcomp/closure_offsets.cmi
asmcomp/closure_offsets.cmx : middle_end/base_types/variable.cmx \
middle_end/base_types/var_within_closure.cmx utils/misc.cmx \
- middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \
- middle_end/flambda.cmx middle_end/base_types/closure_id.cmx \
- asmcomp/closure_offsets.cmi
+ middle_end/flambda_utils.cmx middle_end/flambda.cmx \
+ middle_end/base_types/closure_id.cmx asmcomp/closure_offsets.cmi
asmcomp/closure_offsets.cmi : middle_end/base_types/var_within_closure.cmi \
middle_end/flambda.cmi middle_end/base_types/closure_id.cmi
asmcomp/cmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/arch.cmx asmcomp/comballoc.cmi
asmcomp/comballoc.cmi : asmcomp/mach.cmi
asmcomp/compilenv.cmo : utils/warnings.cmi middle_end/base_types/symbol.cmi \
+ middle_end/simple_value_approx.cmi \
middle_end/base_types/set_of_closures_id.cmi utils/misc.cmi \
parsing/location.cmi middle_end/base_types/linkage_name.cmi \
- typing/ident.cmi middle_end/flambda.cmi asmcomp/export_info.cmi \
- typing/env.cmi utils/config.cmi \
+ typing/ident.cmi asmcomp/export_info.cmi typing/env.cmi utils/config.cmi \
middle_end/base_types/compilation_unit.cmi asmcomp/cmx_format.cmi \
middle_end/base_types/closure_id.cmi utils/clflags.cmi \
asmcomp/clambda.cmi asmcomp/compilenv.cmi
asmcomp/compilenv.cmx : utils/warnings.cmx middle_end/base_types/symbol.cmx \
+ middle_end/simple_value_approx.cmx \
middle_end/base_types/set_of_closures_id.cmx utils/misc.cmx \
parsing/location.cmx middle_end/base_types/linkage_name.cmx \
- typing/ident.cmx middle_end/flambda.cmx asmcomp/export_info.cmx \
- typing/env.cmx utils/config.cmx \
+ typing/ident.cmx asmcomp/export_info.cmx typing/env.cmx utils/config.cmx \
middle_end/base_types/compilation_unit.cmx asmcomp/cmx_format.cmi \
middle_end/base_types/closure_id.cmx utils/clflags.cmx \
asmcomp/clambda.cmx asmcomp/compilenv.cmi
asmcomp/compilenv.cmi : middle_end/base_types/symbol.cmi \
+ middle_end/simple_value_approx.cmi \
middle_end/base_types/set_of_closures_id.cmi \
middle_end/base_types/linkage_name.cmi typing/ident.cmi \
- middle_end/flambda.cmi asmcomp/export_info.cmi \
- middle_end/base_types/compilation_unit.cmi asmcomp/cmx_format.cmi \
- middle_end/base_types/closure_id.cmi asmcomp/clambda.cmi
+ asmcomp/export_info.cmi middle_end/base_types/compilation_unit.cmi \
+ asmcomp/cmx_format.cmi middle_end/base_types/closure_id.cmi \
+ asmcomp/clambda.cmi
asmcomp/deadcode.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
utils/config.cmi asmcomp/deadcode.cmi
asmcomp/deadcode.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
middle_end/base_types/closure_id.cmi
asmcomp/export_info_for_pack.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/var_within_closure.cmi \
- middle_end/base_types/symbol.cmi \
+ middle_end/base_types/symbol.cmi middle_end/simple_value_approx.cmi \
middle_end/base_types/set_of_closures_origin.cmi \
middle_end/base_types/set_of_closures_id.cmi utils/misc.cmi \
- middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
- middle_end/flambda.cmi asmcomp/export_info.cmi \
- middle_end/base_types/export_id.cmi \
+ middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
+ asmcomp/export_info.cmi middle_end/base_types/export_id.cmi \
middle_end/base_types/compilation_unit.cmi \
middle_end/base_types/closure_id.cmi asmcomp/export_info_for_pack.cmi
asmcomp/export_info_for_pack.cmx : middle_end/base_types/variable.cmx \
middle_end/base_types/var_within_closure.cmx \
- middle_end/base_types/symbol.cmx \
+ middle_end/base_types/symbol.cmx middle_end/simple_value_approx.cmx \
middle_end/base_types/set_of_closures_origin.cmx \
middle_end/base_types/set_of_closures_id.cmx utils/misc.cmx \
- middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \
- middle_end/flambda.cmx asmcomp/export_info.cmx \
- middle_end/base_types/export_id.cmx \
+ middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
+ asmcomp/export_info.cmx middle_end/base_types/export_id.cmx \
middle_end/base_types/compilation_unit.cmx \
middle_end/base_types/closure_id.cmx asmcomp/export_info_for_pack.cmi
asmcomp/export_info_for_pack.cmi : asmcomp/export_info.cmi \
middle_end/base_types/var_within_closure.cmi \
middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
middle_end/base_types/static_exception.cmi \
+ middle_end/simple_value_approx.cmi \
middle_end/base_types/set_of_closures_id.cmi typing/primitive.cmi \
middle_end/parameter.cmi utils/numbers.cmi \
middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
- middle_end/base_types/linkage_name.cmi typing/ident.cmi \
+ middle_end/base_types/linkage_name.cmi \
+ middle_end/initialize_symbol_to_let_symbol.cmi typing/ident.cmi \
middle_end/flambda_utils.cmi middle_end/flambda.cmi \
asmcomp/export_info.cmi middle_end/debuginfo.cmi asmcomp/compilenv.cmi \
asmcomp/closure_offsets.cmi middle_end/base_types/closure_id.cmi \
middle_end/base_types/var_within_closure.cmx \
middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \
middle_end/base_types/static_exception.cmx \
+ middle_end/simple_value_approx.cmx \
middle_end/base_types/set_of_closures_id.cmx typing/primitive.cmx \
middle_end/parameter.cmx utils/numbers.cmx \
middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
- middle_end/base_types/linkage_name.cmx typing/ident.cmx \
+ middle_end/base_types/linkage_name.cmx \
+ middle_end/initialize_symbol_to_let_symbol.cmx typing/ident.cmx \
middle_end/flambda_utils.cmx middle_end/flambda.cmx \
asmcomp/export_info.cmx middle_end/debuginfo.cmx asmcomp/compilenv.cmx \
asmcomp/closure_offsets.cmx middle_end/base_types/closure_id.cmx \
middle_end/freshening.cmi middle_end/flambda_iterators.cmi \
middle_end/flambda.cmi asmcomp/export_info.cmi \
middle_end/base_types/export_id.cmi asmcomp/compilenv.cmi \
+ middle_end/base_types/compilation_unit.cmi \
middle_end/base_types/closure_id.cmi asmcomp/import_approx.cmi
asmcomp/import_approx.cmx : middle_end/base_types/variable.cmx \
middle_end/base_types/var_within_closure.cmx \
middle_end/freshening.cmx middle_end/flambda_iterators.cmx \
middle_end/flambda.cmx asmcomp/export_info.cmx \
middle_end/base_types/export_id.cmx asmcomp/compilenv.cmx \
+ middle_end/base_types/compilation_unit.cmx \
middle_end/base_types/closure_id.cmx asmcomp/import_approx.cmi
asmcomp/import_approx.cmi : middle_end/base_types/symbol.cmi \
middle_end/simple_value_approx.cmi
parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/strmatch.cmi
asmcomp/strmatch.cmi : parsing/location.cmi middle_end/debuginfo.cmi \
asmcomp/cmm.cmi
+asmcomp/traverse_for_exported_symbols.cmo : \
+ middle_end/base_types/variable.cmi \
+ middle_end/base_types/var_within_closure.cmi \
+ middle_end/base_types/symbol.cmi middle_end/simple_value_approx.cmi \
+ middle_end/base_types/set_of_closures_id.cmi utils/misc.cmi \
+ middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
+ asmcomp/export_info.cmi middle_end/base_types/export_id.cmi \
+ middle_end/base_types/compilation_unit.cmi \
+ middle_end/base_types/closure_id.cmi \
+ asmcomp/traverse_for_exported_symbols.cmi
+asmcomp/traverse_for_exported_symbols.cmx : \
+ middle_end/base_types/variable.cmx \
+ middle_end/base_types/var_within_closure.cmx \
+ middle_end/base_types/symbol.cmx middle_end/simple_value_approx.cmx \
+ middle_end/base_types/set_of_closures_id.cmx utils/misc.cmx \
+ middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
+ asmcomp/export_info.cmx middle_end/base_types/export_id.cmx \
+ middle_end/base_types/compilation_unit.cmx \
+ middle_end/base_types/closure_id.cmx \
+ asmcomp/traverse_for_exported_symbols.cmi
+asmcomp/traverse_for_exported_symbols.cmi : \
+ middle_end/base_types/var_within_closure.cmi \
+ middle_end/base_types/symbol.cmi middle_end/simple_value_approx.cmi \
+ middle_end/base_types/set_of_closures_id.cmi middle_end/flambda.cmi \
+ asmcomp/export_info.cmi middle_end/base_types/export_id.cmi \
+ middle_end/base_types/closure_id.cmi
asmcomp/un_anf.cmo : bytecomp/semantics_of_primitives.cmi \
asmcomp/printclambda.cmi utils/misc.cmi bytecomp/lambda.cmi \
typing/ident.cmi middle_end/debuginfo.cmi utils/clflags.cmi \
middle_end/allocated_const.cmi :
middle_end/augment_specialised_args.cmo : middle_end/base_types/variable.cmi \
middle_end/projection.cmi middle_end/pass_wrapper.cmi \
- middle_end/parameter.cmi utils/misc.cmi middle_end/inlining_cost.cmi \
+ middle_end/parameter.cmi utils/misc.cmi \
+ middle_end/internal_variable_names.cmi middle_end/inlining_cost.cmi \
middle_end/inline_and_simplify_aux.cmi utils/identifiable.cmi \
middle_end/flambda_utils.cmi middle_end/flambda.cmi \
- middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi \
- utils/clflags.cmi middle_end/backend_intf.cmi \
- middle_end/augment_specialised_args.cmi
+ middle_end/debuginfo.cmi middle_end/base_types/closure_origin.cmi \
+ middle_end/base_types/closure_id.cmi utils/clflags.cmi \
+ middle_end/backend_intf.cmi middle_end/augment_specialised_args.cmi
middle_end/augment_specialised_args.cmx : middle_end/base_types/variable.cmx \
middle_end/projection.cmx middle_end/pass_wrapper.cmx \
- middle_end/parameter.cmx utils/misc.cmx middle_end/inlining_cost.cmx \
+ middle_end/parameter.cmx utils/misc.cmx \
+ middle_end/internal_variable_names.cmx middle_end/inlining_cost.cmx \
middle_end/inline_and_simplify_aux.cmx utils/identifiable.cmx \
middle_end/flambda_utils.cmx middle_end/flambda.cmx \
- middle_end/debuginfo.cmx middle_end/base_types/closure_id.cmx \
- utils/clflags.cmx middle_end/backend_intf.cmi \
- middle_end/augment_specialised_args.cmi
+ middle_end/debuginfo.cmx middle_end/base_types/closure_origin.cmx \
+ middle_end/base_types/closure_id.cmx utils/clflags.cmx \
+ middle_end/backend_intf.cmi middle_end/augment_specialised_args.cmi
middle_end/augment_specialised_args.cmi : middle_end/base_types/variable.cmi \
middle_end/projection.cmi middle_end/inlining_cost.cmi \
middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi
middle_end/closure_conversion.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
middle_end/base_types/static_exception.cmi bytecomp/simplif.cmi \
- bytecomp/printlambda.cmi typing/predef.cmi middle_end/parameter.cmi \
- utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \
- utils/misc.cmi parsing/location.cmi \
- middle_end/base_types/linkage_name.cmi middle_end/lift_code.cmi \
- bytecomp/lambda.cmi typing/ident.cmi middle_end/flambda_utils.cmi \
- middle_end/flambda.cmi middle_end/debuginfo.cmi utils/config.cmi \
+ typing/predef.cmi middle_end/parameter.cmi utils/numbers.cmi \
+ middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
+ middle_end/lift_code.cmi bytecomp/lambda.cmi \
+ middle_end/internal_variable_names.cmi typing/ident.cmi \
+ middle_end/flambda_utils.cmi middle_end/flambda.cmi \
+ middle_end/debuginfo.cmi utils/config.cmi \
middle_end/base_types/compilation_unit.cmi \
+ middle_end/base_types/closure_origin.cmi \
middle_end/base_types/closure_id.cmi \
middle_end/closure_conversion_aux.cmi utils/clflags.cmi \
middle_end/backend_intf.cmi middle_end/closure_conversion.cmi
middle_end/closure_conversion.cmx : middle_end/base_types/variable.cmx \
middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \
middle_end/base_types/static_exception.cmx bytecomp/simplif.cmx \
- bytecomp/printlambda.cmx typing/predef.cmx middle_end/parameter.cmx \
- utils/numbers.cmx middle_end/base_types/mutable_variable.cmx \
- utils/misc.cmx parsing/location.cmx \
- middle_end/base_types/linkage_name.cmx middle_end/lift_code.cmx \
- bytecomp/lambda.cmx typing/ident.cmx middle_end/flambda_utils.cmx \
- middle_end/flambda.cmx middle_end/debuginfo.cmx utils/config.cmx \
+ typing/predef.cmx middle_end/parameter.cmx utils/numbers.cmx \
+ middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
+ middle_end/lift_code.cmx bytecomp/lambda.cmx \
+ middle_end/internal_variable_names.cmx typing/ident.cmx \
+ middle_end/flambda_utils.cmx middle_end/flambda.cmx \
+ middle_end/debuginfo.cmx utils/config.cmx \
middle_end/base_types/compilation_unit.cmx \
+ middle_end/base_types/closure_origin.cmx \
middle_end/base_types/closure_id.cmx \
middle_end/closure_conversion_aux.cmx utils/clflags.cmx \
middle_end/backend_intf.cmi middle_end/closure_conversion.cmi
middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
bytecomp/lambda.cmi utils/identifiable.cmi middle_end/debuginfo.cmi \
middle_end/base_types/compilation_unit.cmi \
+ middle_end/base_types/closure_origin.cmi \
middle_end/base_types/closure_id.cmi utils/clflags.cmi \
parsing/asttypes.cmi middle_end/allocated_const.cmi \
middle_end/flambda.cmi
middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
bytecomp/lambda.cmx utils/identifiable.cmx middle_end/debuginfo.cmx \
middle_end/base_types/compilation_unit.cmx \
+ middle_end/base_types/closure_origin.cmx \
middle_end/base_types/closure_id.cmx utils/clflags.cmx \
parsing/asttypes.cmi middle_end/allocated_const.cmx \
middle_end/flambda.cmi
middle_end/parameter.cmi utils/numbers.cmi \
middle_end/base_types/mutable_variable.cmi bytecomp/lambda.cmi \
utils/identifiable.cmi middle_end/debuginfo.cmi \
+ middle_end/base_types/closure_origin.cmi \
middle_end/base_types/closure_id.cmi parsing/asttypes.cmi \
middle_end/allocated_const.cmi
middle_end/flambda_invariants.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/static_exception.cmi \
middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
middle_end/parameter.cmi middle_end/base_types/mutable_variable.cmi \
- utils/misc.cmi middle_end/base_types/linkage_name.cmi bytecomp/lambda.cmi \
+ utils/misc.cmi bytecomp/lambda.cmi middle_end/internal_variable_names.cmi \
middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
middle_end/debuginfo.cmi middle_end/base_types/compilation_unit.cmi \
+ middle_end/base_types/closure_origin.cmi \
middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi \
middle_end/allocated_const.cmi middle_end/flambda_utils.cmi
middle_end/flambda_utils.cmx : middle_end/base_types/variable.cmx \
middle_end/base_types/static_exception.cmx \
middle_end/base_types/set_of_closures_id.cmx middle_end/projection.cmx \
middle_end/parameter.cmx middle_end/base_types/mutable_variable.cmx \
- utils/misc.cmx middle_end/base_types/linkage_name.cmx bytecomp/lambda.cmx \
+ utils/misc.cmx bytecomp/lambda.cmx middle_end/internal_variable_names.cmx \
middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
middle_end/debuginfo.cmx middle_end/base_types/compilation_unit.cmx \
+ middle_end/base_types/closure_origin.cmx \
middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \
middle_end/allocated_const.cmx middle_end/flambda_utils.cmi
middle_end/flambda_utils.cmi : middle_end/base_types/variable.cmi \
middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
bytecomp/switch.cmi middle_end/base_types/static_exception.cmi \
middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
- middle_end/parameter.cmi middle_end/flambda.cmi \
- middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi
+ middle_end/parameter.cmi middle_end/internal_variable_names.cmi \
+ middle_end/flambda.cmi middle_end/base_types/closure_id.cmi \
+ middle_end/backend_intf.cmi
middle_end/freshening.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/var_within_closure.cmi \
middle_end/base_types/symbol.cmi \
middle_end/remove_free_vars_equal_to_args.cmi middle_end/projection.cmi \
typing/predef.cmi middle_end/parameter.cmi utils/misc.cmi \
parsing/location.cmi middle_end/lift_code.cmi bytecomp/lambda.cmi \
- middle_end/invariant_params.cmi middle_end/inlining_stats.cmi \
- middle_end/inlining_decision.cmi middle_end/inlining_cost.cmi \
- middle_end/inline_and_simplify_aux.cmi typing/ident.cmi \
- middle_end/freshening.cmi middle_end/flambda_utils.cmi \
- middle_end/flambda.cmi middle_end/effect_analysis.cmi \
- middle_end/debuginfo.cmi utils/config.cmi \
+ middle_end/invariant_params.cmi middle_end/internal_variable_names.cmi \
+ middle_end/inlining_stats.cmi middle_end/inlining_decision.cmi \
+ middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \
+ typing/ident.cmi middle_end/freshening.cmi middle_end/flambda_utils.cmi \
+ middle_end/flambda.cmi middle_end/find_recursive_functions.cmi \
+ middle_end/effect_analysis.cmi middle_end/debuginfo.cmi utils/config.cmi \
+ middle_end/base_types/closure_origin.cmi \
middle_end/base_types/closure_id.cmi utils/clflags.cmi \
middle_end/backend_intf.cmi middle_end/allocated_const.cmi \
middle_end/inline_and_simplify.cmi
middle_end/remove_free_vars_equal_to_args.cmx middle_end/projection.cmx \
typing/predef.cmx middle_end/parameter.cmx utils/misc.cmx \
parsing/location.cmx middle_end/lift_code.cmx bytecomp/lambda.cmx \
- middle_end/invariant_params.cmx middle_end/inlining_stats.cmx \
- middle_end/inlining_decision.cmx middle_end/inlining_cost.cmx \
- middle_end/inline_and_simplify_aux.cmx typing/ident.cmx \
- middle_end/freshening.cmx middle_end/flambda_utils.cmx \
- middle_end/flambda.cmx middle_end/effect_analysis.cmx \
- middle_end/debuginfo.cmx utils/config.cmx \
+ middle_end/invariant_params.cmx middle_end/internal_variable_names.cmx \
+ middle_end/inlining_stats.cmx middle_end/inlining_decision.cmx \
+ middle_end/inlining_cost.cmx middle_end/inline_and_simplify_aux.cmx \
+ typing/ident.cmx middle_end/freshening.cmx middle_end/flambda_utils.cmx \
+ middle_end/flambda.cmx middle_end/find_recursive_functions.cmx \
+ middle_end/effect_analysis.cmx middle_end/debuginfo.cmx utils/config.cmx \
+ middle_end/base_types/closure_origin.cmx \
middle_end/base_types/closure_id.cmx utils/clflags.cmx \
middle_end/backend_intf.cmi middle_end/allocated_const.cmx \
middle_end/inline_and_simplify.cmi
middle_end/projection.cmi middle_end/parameter.cmi \
middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
middle_end/inlining_stats.cmi middle_end/inlining_cost.cmi \
- middle_end/freshening.cmi middle_end/flambda.cmi middle_end/debuginfo.cmi \
+ middle_end/freshening.cmi middle_end/flambda_utils.cmi \
+ middle_end/flambda.cmi middle_end/debuginfo.cmi \
middle_end/base_types/compilation_unit.cmi \
+ middle_end/base_types/closure_origin.cmi \
middle_end/base_types/closure_id.cmi utils/clflags.cmi \
middle_end/backend_intf.cmi middle_end/inline_and_simplify_aux.cmi
middle_end/inline_and_simplify_aux.cmx : middle_end/base_types/variable.cmx \
middle_end/projection.cmx middle_end/parameter.cmx \
middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
middle_end/inlining_stats.cmx middle_end/inlining_cost.cmx \
- middle_end/freshening.cmx middle_end/flambda.cmx middle_end/debuginfo.cmx \
+ middle_end/freshening.cmx middle_end/flambda_utils.cmx \
+ middle_end/flambda.cmx middle_end/debuginfo.cmx \
middle_end/base_types/compilation_unit.cmx \
+ middle_end/base_types/closure_origin.cmx \
middle_end/base_types/closure_id.cmx utils/clflags.cmx \
middle_end/backend_intf.cmi middle_end/inline_and_simplify_aux.cmi
middle_end/inline_and_simplify_aux.cmi : middle_end/base_types/variable.cmi \
middle_end/projection.cmi middle_end/base_types/mutable_variable.cmi \
middle_end/inlining_stats_types.cmi middle_end/inlining_cost.cmi \
middle_end/freshening.cmi middle_end/flambda.cmi middle_end/debuginfo.cmi \
+ middle_end/base_types/closure_origin.cmi \
middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi
middle_end/inlining_cost.cmo : middle_end/base_types/variable.cmi \
middle_end/projection.cmi typing/primitive.cmi utils/misc.cmi \
middle_end/simple_value_approx.cmi middle_end/parameter.cmi \
utils/misc.cmi bytecomp/lambda.cmi middle_end/inlining_transforms.cmi \
middle_end/inlining_stats_types.cmi middle_end/inlining_cost.cmi \
- middle_end/inline_and_simplify_aux.cmi middle_end/flambda_utils.cmi \
- middle_end/flambda.cmi middle_end/find_recursive_functions.cmi \
+ middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \
middle_end/base_types/closure_id.cmi utils/clflags.cmi \
middle_end/inlining_decision.cmi
middle_end/inlining_decision.cmx : middle_end/base_types/variable.cmx \
middle_end/simple_value_approx.cmx middle_end/parameter.cmx \
utils/misc.cmx bytecomp/lambda.cmx middle_end/inlining_transforms.cmx \
middle_end/inlining_stats_types.cmx middle_end/inlining_cost.cmx \
- middle_end/inline_and_simplify_aux.cmx middle_end/flambda_utils.cmx \
- middle_end/flambda.cmx middle_end/find_recursive_functions.cmx \
+ middle_end/inline_and_simplify_aux.cmx middle_end/flambda.cmx \
middle_end/base_types/closure_id.cmx utils/clflags.cmx \
middle_end/inlining_decision.cmi
middle_end/inlining_decision.cmi : middle_end/base_types/variable.cmi \
middle_end/inlining_stats_types.cmi : middle_end/inlining_cost.cmi
middle_end/inlining_transforms.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/var_within_closure.cmi \
- middle_end/simple_value_approx.cmi middle_end/parameter.cmi \
- utils/misc.cmi bytecomp/lambda.cmi middle_end/inlining_cost.cmi \
- middle_end/inline_and_simplify_aux.cmi middle_end/freshening.cmi \
- middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
- middle_end/flambda.cmi middle_end/base_types/compilation_unit.cmi \
- middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi \
- middle_end/inlining_transforms.cmi
+ middle_end/simple_value_approx.cmi middle_end/projection.cmi \
+ middle_end/parameter.cmi bytecomp/lambda.cmi \
+ middle_end/internal_variable_names.cmi \
+ middle_end/inlining_decision_intf.cmi middle_end/inlining_cost.cmi \
+ middle_end/inline_and_simplify_aux.cmi middle_end/flambda_utils.cmi \
+ middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
+ middle_end/debuginfo.cmi middle_end/base_types/compilation_unit.cmi \
+ middle_end/base_types/closure_origin.cmi \
+ middle_end/base_types/closure_id.cmi middle_end/inlining_transforms.cmi
middle_end/inlining_transforms.cmx : middle_end/base_types/variable.cmx \
middle_end/base_types/var_within_closure.cmx \
- middle_end/simple_value_approx.cmx middle_end/parameter.cmx \
- utils/misc.cmx bytecomp/lambda.cmx middle_end/inlining_cost.cmx \
- middle_end/inline_and_simplify_aux.cmx middle_end/freshening.cmx \
- middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \
- middle_end/flambda.cmx middle_end/base_types/compilation_unit.cmx \
- middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \
- middle_end/inlining_transforms.cmi
+ middle_end/simple_value_approx.cmx middle_end/projection.cmx \
+ middle_end/parameter.cmx bytecomp/lambda.cmx \
+ middle_end/internal_variable_names.cmx \
+ middle_end/inlining_decision_intf.cmi middle_end/inlining_cost.cmx \
+ middle_end/inline_and_simplify_aux.cmx middle_end/flambda_utils.cmx \
+ middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
+ middle_end/debuginfo.cmx middle_end/base_types/compilation_unit.cmx \
+ middle_end/base_types/closure_origin.cmx \
+ middle_end/base_types/closure_id.cmx middle_end/inlining_transforms.cmi
middle_end/inlining_transforms.cmi : middle_end/base_types/variable.cmi \
middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \
middle_end/inlining_decision_intf.cmi \
middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \
middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi
+middle_end/internal_variable_names.cmo : parsing/location.cmi \
+ bytecomp/lambda.cmi middle_end/internal_variable_names.cmi
+middle_end/internal_variable_names.cmx : parsing/location.cmx \
+ bytecomp/lambda.cmx middle_end/internal_variable_names.cmi
+middle_end/internal_variable_names.cmi : parsing/location.cmi \
+ bytecomp/lambda.cmi
middle_end/invariant_params.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/symbol.cmi middle_end/parameter.cmi \
middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
middle_end/flambda.cmx middle_end/base_types/compilation_unit.cmx \
middle_end/lift_code.cmi
middle_end/lift_code.cmi : middle_end/base_types/variable.cmi \
- middle_end/flambda.cmi
+ middle_end/internal_variable_names.cmi middle_end/flambda.cmi
middle_end/lift_constants.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/var_within_closure.cmi \
middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
utils/strongly_connected_components.cmi \
middle_end/simple_value_approx.cmi utils/misc.cmi \
- middle_end/base_types/linkage_name.cmi middle_end/inconstant_idents.cmi \
+ middle_end/internal_variable_names.cmi middle_end/inconstant_idents.cmi \
middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
middle_end/flambda.cmi middle_end/base_types/compilation_unit.cmi \
middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi \
middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \
utils/strongly_connected_components.cmx \
middle_end/simple_value_approx.cmx utils/misc.cmx \
- middle_end/base_types/linkage_name.cmx middle_end/inconstant_idents.cmx \
+ middle_end/internal_variable_names.cmx middle_end/inconstant_idents.cmx \
middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \
middle_end/flambda.cmx middle_end/base_types/compilation_unit.cmx \
middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \
middle_end/backend_intf.cmi
middle_end/lift_let_to_initialize_symbol.cmo : \
middle_end/base_types/variable.cmi middle_end/base_types/tag.cmi \
- middle_end/base_types/symbol.cmi middle_end/flambda_utils.cmi \
- middle_end/flambda.cmi middle_end/debuginfo.cmi parsing/asttypes.cmi \
+ middle_end/base_types/symbol.cmi middle_end/internal_variable_names.cmi \
+ middle_end/flambda_utils.cmi middle_end/flambda.cmi \
+ middle_end/debuginfo.cmi parsing/asttypes.cmi \
middle_end/lift_let_to_initialize_symbol.cmi
middle_end/lift_let_to_initialize_symbol.cmx : \
middle_end/base_types/variable.cmx middle_end/base_types/tag.cmx \
- middle_end/base_types/symbol.cmx middle_end/flambda_utils.cmx \
- middle_end/flambda.cmx middle_end/debuginfo.cmx parsing/asttypes.cmi \
+ middle_end/base_types/symbol.cmx middle_end/internal_variable_names.cmx \
+ middle_end/flambda_utils.cmx middle_end/flambda.cmx \
+ middle_end/debuginfo.cmx parsing/asttypes.cmi \
middle_end/lift_let_to_initialize_symbol.cmi
middle_end/lift_let_to_initialize_symbol.cmi : middle_end/flambda.cmi \
middle_end/backend_intf.cmi
middle_end/base_types/closure_id.cmi
middle_end/ref_to_variables.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
- bytecomp/lambda.cmi middle_end/flambda_iterators.cmi \
- middle_end/flambda.cmi parsing/asttypes.cmi \
- middle_end/ref_to_variables.cmi
+ bytecomp/lambda.cmi middle_end/internal_variable_names.cmi \
+ middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
+ parsing/asttypes.cmi middle_end/ref_to_variables.cmi
middle_end/ref_to_variables.cmx : middle_end/base_types/variable.cmx \
middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
- bytecomp/lambda.cmx middle_end/flambda_iterators.cmx \
- middle_end/flambda.cmx parsing/asttypes.cmi \
- middle_end/ref_to_variables.cmi
+ bytecomp/lambda.cmx middle_end/internal_variable_names.cmx \
+ middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
+ parsing/asttypes.cmi middle_end/ref_to_variables.cmi
middle_end/ref_to_variables.cmi : middle_end/flambda.cmi
middle_end/remove_free_vars_equal_to_args.cmo : \
middle_end/base_types/variable.cmi middle_end/pass_wrapper.cmi \
middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
middle_end/find_recursive_functions.cmi \
middle_end/base_types/compilation_unit.cmi \
+ middle_end/base_types/closure_origin.cmi \
middle_end/base_types/closure_id.cmi utils/clflags.cmi \
middle_end/remove_unused_arguments.cmi
middle_end/remove_unused_arguments.cmx : middle_end/base_types/variable.cmx \
middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
middle_end/find_recursive_functions.cmx \
middle_end/base_types/compilation_unit.cmx \
+ middle_end/base_types/closure_origin.cmx \
middle_end/base_types/closure_id.cmx utils/clflags.cmx \
middle_end/remove_unused_arguments.cmi
middle_end/remove_unused_arguments.cmi : middle_end/flambda.cmi \
middle_end/simple_value_approx.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/var_within_closure.cmi \
middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
+ middle_end/base_types/set_of_closures_origin.cmi \
middle_end/base_types/set_of_closures_id.cmi middle_end/parameter.cmi \
- utils/misc.cmi bytecomp/lambda.cmi middle_end/inlining_cost.cmi \
- middle_end/freshening.cmi middle_end/flambda_utils.cmi \
- middle_end/flambda.cmi middle_end/base_types/export_id.cmi \
- middle_end/effect_analysis.cmi middle_end/base_types/closure_id.cmi \
- middle_end/allocated_const.cmi middle_end/simple_value_approx.cmi
+ utils/misc.cmi bytecomp/lambda.cmi middle_end/internal_variable_names.cmi \
+ middle_end/inlining_cost.cmi middle_end/freshening.cmi \
+ middle_end/flambda_utils.cmi middle_end/flambda.cmi \
+ middle_end/base_types/export_id.cmi middle_end/effect_analysis.cmi \
+ middle_end/debuginfo.cmi middle_end/base_types/compilation_unit.cmi \
+ middle_end/base_types/closure_origin.cmi \
+ middle_end/base_types/closure_id.cmi middle_end/allocated_const.cmi \
+ middle_end/simple_value_approx.cmi
middle_end/simple_value_approx.cmx : middle_end/base_types/variable.cmx \
middle_end/base_types/var_within_closure.cmx \
middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \
+ middle_end/base_types/set_of_closures_origin.cmx \
middle_end/base_types/set_of_closures_id.cmx middle_end/parameter.cmx \
- utils/misc.cmx bytecomp/lambda.cmx middle_end/inlining_cost.cmx \
- middle_end/freshening.cmx middle_end/flambda_utils.cmx \
- middle_end/flambda.cmx middle_end/base_types/export_id.cmx \
- middle_end/effect_analysis.cmx middle_end/base_types/closure_id.cmx \
- middle_end/allocated_const.cmx middle_end/simple_value_approx.cmi
+ utils/misc.cmx bytecomp/lambda.cmx middle_end/internal_variable_names.cmx \
+ middle_end/inlining_cost.cmx middle_end/freshening.cmx \
+ middle_end/flambda_utils.cmx middle_end/flambda.cmx \
+ middle_end/base_types/export_id.cmx middle_end/effect_analysis.cmx \
+ middle_end/debuginfo.cmx middle_end/base_types/compilation_unit.cmx \
+ middle_end/base_types/closure_origin.cmx \
+ middle_end/base_types/closure_id.cmx middle_end/allocated_const.cmx \
+ middle_end/simple_value_approx.cmi
middle_end/simple_value_approx.cmi : middle_end/base_types/variable.cmi \
middle_end/base_types/var_within_closure.cmi \
middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
- middle_end/base_types/set_of_closures_id.cmi bytecomp/lambda.cmi \
- middle_end/freshening.cmi middle_end/flambda.cmi \
- middle_end/base_types/export_id.cmi middle_end/base_types/closure_id.cmi
+ middle_end/base_types/set_of_closures_origin.cmi \
+ middle_end/base_types/set_of_closures_id.cmi middle_end/parameter.cmi \
+ bytecomp/lambda.cmi middle_end/freshening.cmi middle_end/flambda.cmi \
+ middle_end/base_types/export_id.cmi middle_end/debuginfo.cmi \
+ middle_end/base_types/closure_origin.cmi \
+ middle_end/base_types/closure_id.cmi
middle_end/simplify_boxed_integer_ops.cmo : middle_end/simplify_common.cmi \
middle_end/simplify_boxed_integer_ops_intf.cmi \
middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \
middle_end/flambda.cmi
middle_end/unbox_free_vars_of_closures.cmo : \
middle_end/base_types/variable.cmi middle_end/projection.cmi \
- middle_end/pass_wrapper.cmi utils/misc.cmi middle_end/inlining_cost.cmi \
+ middle_end/pass_wrapper.cmi utils/misc.cmi \
+ middle_end/internal_variable_names.cmi middle_end/inlining_cost.cmi \
middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
middle_end/flambda.cmi middle_end/extract_projections.cmi \
utils/clflags.cmi middle_end/unbox_free_vars_of_closures.cmi
middle_end/unbox_free_vars_of_closures.cmx : \
middle_end/base_types/variable.cmx middle_end/projection.cmx \
- middle_end/pass_wrapper.cmx utils/misc.cmx middle_end/inlining_cost.cmx \
+ middle_end/pass_wrapper.cmx utils/misc.cmx \
+ middle_end/internal_variable_names.cmx middle_end/inlining_cost.cmx \
middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \
middle_end/flambda.cmx middle_end/extract_projections.cmx \
utils/clflags.cmx middle_end/unbox_free_vars_of_closures.cmi
middle_end/base_types/closure_id.cmi
middle_end/base_types/closure_id.cmi : \
middle_end/base_types/closure_element.cmi
+middle_end/base_types/closure_origin.cmo : \
+ middle_end/base_types/closure_id.cmi \
+ middle_end/base_types/closure_origin.cmi
+middle_end/base_types/closure_origin.cmx : \
+ middle_end/base_types/closure_id.cmx \
+ middle_end/base_types/closure_origin.cmi
+middle_end/base_types/closure_origin.cmi : utils/identifiable.cmi \
+ middle_end/base_types/compilation_unit.cmi \
+ middle_end/base_types/closure_id.cmi
middle_end/base_types/compilation_unit.cmo : utils/misc.cmi \
middle_end/base_types/linkage_name.cmi utils/identifiable.cmi \
typing/ident.cmi middle_end/base_types/compilation_unit.cmi
middle_end/base_types/linkage_name.cmx : utils/identifiable.cmx \
middle_end/base_types/linkage_name.cmi
middle_end/base_types/linkage_name.cmi : utils/identifiable.cmi
-middle_end/base_types/mutable_variable.cmo : utils/identifiable.cmi \
- typing/ident.cmi middle_end/base_types/compilation_unit.cmi \
+middle_end/base_types/mutable_variable.cmo : \
+ middle_end/base_types/variable.cmi \
middle_end/base_types/mutable_variable.cmi
-middle_end/base_types/mutable_variable.cmx : utils/identifiable.cmx \
- typing/ident.cmx middle_end/base_types/compilation_unit.cmx \
+middle_end/base_types/mutable_variable.cmx : \
+ middle_end/base_types/variable.cmx \
middle_end/base_types/mutable_variable.cmi
-middle_end/base_types/mutable_variable.cmi : utils/identifiable.cmi \
- typing/ident.cmi middle_end/base_types/compilation_unit.cmi
+middle_end/base_types/mutable_variable.cmi : \
+ middle_end/base_types/variable.cmi middle_end/internal_variable_names.cmi \
+ utils/identifiable.cmi typing/ident.cmi \
+ middle_end/base_types/compilation_unit.cmi
middle_end/base_types/set_of_closures_id.cmo : utils/identifiable.cmi \
middle_end/base_types/id_types.cmi \
middle_end/base_types/compilation_unit.cmi \
middle_end/base_types/static_exception.cmx : utils/numbers.cmx \
bytecomp/lambda.cmx middle_end/base_types/static_exception.cmi
middle_end/base_types/static_exception.cmi : utils/identifiable.cmi
-middle_end/base_types/symbol.cmo : utils/misc.cmi \
- middle_end/base_types/linkage_name.cmi utils/identifiable.cmi \
- middle_end/base_types/compilation_unit.cmi \
+middle_end/base_types/symbol.cmo : middle_end/base_types/variable.cmi \
+ utils/misc.cmi middle_end/base_types/linkage_name.cmi \
+ utils/identifiable.cmi middle_end/base_types/compilation_unit.cmi \
middle_end/base_types/symbol.cmi
-middle_end/base_types/symbol.cmx : utils/misc.cmx \
- middle_end/base_types/linkage_name.cmx utils/identifiable.cmx \
- middle_end/base_types/compilation_unit.cmx \
+middle_end/base_types/symbol.cmx : middle_end/base_types/variable.cmx \
+ utils/misc.cmx middle_end/base_types/linkage_name.cmx \
+ utils/identifiable.cmx middle_end/base_types/compilation_unit.cmx \
middle_end/base_types/symbol.cmi
-middle_end/base_types/symbol.cmi : middle_end/base_types/linkage_name.cmi \
- utils/identifiable.cmi middle_end/base_types/compilation_unit.cmi
+middle_end/base_types/symbol.cmi : middle_end/base_types/variable.cmi \
+ middle_end/base_types/linkage_name.cmi utils/identifiable.cmi \
+ middle_end/base_types/compilation_unit.cmi
middle_end/base_types/tag.cmo : utils/numbers.cmi utils/misc.cmi \
utils/identifiable.cmi middle_end/base_types/tag.cmi
middle_end/base_types/tag.cmx : utils/numbers.cmx utils/misc.cmx \
middle_end/base_types/var_within_closure.cmi
middle_end/base_types/var_within_closure.cmi : \
middle_end/base_types/closure_element.cmi
-middle_end/base_types/variable.cmo : utils/misc.cmi utils/identifiable.cmi \
+middle_end/base_types/variable.cmo : utils/misc.cmi \
+ middle_end/internal_variable_names.cmi utils/identifiable.cmi \
typing/ident.cmi middle_end/base_types/compilation_unit.cmi \
middle_end/base_types/variable.cmi
-middle_end/base_types/variable.cmx : utils/misc.cmx utils/identifiable.cmx \
+middle_end/base_types/variable.cmx : utils/misc.cmx \
+ middle_end/internal_variable_names.cmx utils/identifiable.cmx \
typing/ident.cmx middle_end/base_types/compilation_unit.cmx \
middle_end/base_types/variable.cmi
-middle_end/base_types/variable.cmi : utils/identifiable.cmi typing/ident.cmi \
+middle_end/base_types/variable.cmi : middle_end/internal_variable_names.cmi \
+ utils/identifiable.cmi typing/ident.cmi \
middle_end/base_types/compilation_unit.cmi
asmcomp/debug/available_regs.cmo : asmcomp/debug/reg_with_debug_info.cmi \
asmcomp/debug/reg_availability_set.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
bytecomp/bytegen.cmx parsing/builtin_attributes.cmx driver/compile.cmi
driver/compile.cmi :
driver/compmisc.cmo : utils/warnings.cmi typing/typemod.cmi utils/misc.cmi \
- parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
- typing/env.cmi utils/config.cmi driver/compenv.cmi utils/clflags.cmi \
- parsing/asttypes.cmi driver/compmisc.cmi
+ parsing/location.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \
+ driver/compenv.cmi utils/clflags.cmi driver/compmisc.cmi
driver/compmisc.cmx : utils/warnings.cmx typing/typemod.cmx utils/misc.cmx \
- parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
- typing/env.cmx utils/config.cmx driver/compenv.cmx utils/clflags.cmx \
- parsing/asttypes.cmi driver/compmisc.cmi
+ parsing/location.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \
+ driver/compenv.cmx utils/clflags.cmx driver/compmisc.cmi
driver/compmisc.cmi : typing/env.cmi
driver/compplugin.cmo : utils/misc.cmi parsing/location.cmi utils/config.cmi \
driver/compmisc.cmi driver/compenv.cmi driver/compdynlink.cmi \
/Changes ocaml-typo=non-ascii,missing-header
/INSTALL ocaml-typo=missing-header
/LICENSE ocaml-typo=long-line,very-long-line,missing-header
-# appveyor_build.cmd only has missing-header because dra27 too lazy to update
-# check-typo to interpret Cmd-style comments!
-/appveyor_build.cmd ocaml-typo=long-line,very-long-line,missing-header text eol=crlf
-/appveyor_build.sh ocaml-typo=non-ascii
+# tools/ci/appveyor/appveyor_build.cmd only has missing-header because
+# dra27 too lazy to update check-typo to interpret Cmd-style comments!
+/tools/ci/appveyor/appveyor_build.cmd ocaml-typo=long-line,very-long-line,missing-header text eol=crlf
+/tools/ci/appveyor/appveyor_build.sh ocaml-typo=non-ascii
asmcomp/*/emit.mlp ocaml-typo=tab,long-line,unused-prop
# Test suite command fragments
*.checker text eol=lf
*.precheck text eol=lf
-*.runner text eol=lf
+# ocamltest hooks which are used in the testsuite
+*.check-program-output text eol=lf
+*.run text eol=lf
configure text eol=lf
config/auto-aux/hasgot text eol=lf
# Tests which include references spanning multiple lines fail with \r\n
# endings, so use \n endings only, even on Windows.
+testsuite/tests/basic-more/morematch.ml text eol=lf
+testsuite/tests/basic-more/robustmatch.ml text eol=lf
testsuite/tests/parsing/*.ml text eol=lf
testsuite/tests/docstrings/empty.ml text eol=lf
testsuite/tests/functors/functors.ml text eol=lf
testsuite/tests/translprim/module_coercion.ml text eol=lf
+testsuite/tests/typing-objects-bugs/pr3968_bad.ml text eol=lf
+testsuite/tests/typing-recmod/t12bad.ml text eol=lf
+testsuite/tests/typing-safe-linking/b_bad.ml text eol=lf
testsuite/tests/warnings/w04.ml text eol=lf
testsuite/tests/warnings/w04_failure.ml text eol=lf
testsuite/tests/warnings/w32.ml text eol=lf
testsuite/tests/formatting/margins.ml text eol=lf
testsuite/tests/letrec-disallowed/disallowed.ml text eol=lf
testsuite/tests/letrec-disallowed/extension_constructor.ml text eol=lf
-testsuite/tests/letrec-disallowed/float_block.ml text eol=lf
+testsuite/tests/letrec-disallowed/float_block_allowed.ml text eol=lf
+testsuite/tests/letrec-disallowed/float_block_disallowed.ml text eol=lf
testsuite/tests/letrec-disallowed/generic_arrays.ml text eol=lf
+testsuite/tests/letrec-disallowed/lazy_.ml text eol=lf
testsuite/tests/letrec-disallowed/module_constraints.ml text eol=lf
+testsuite/tests/letrec-disallowed/unboxed.ml text eol=lf
testsuite/tests/letrec-disallowed/pr7215.ml text eol=lf
+testsuite/tests/letrec-disallowed/pr7231.ml text eol=lf
+testsuite/tests/letrec-disallowed/pr7706.ml text eol=lf
testsuite/tests/lexing/uchar_esc.ml text eol=lf
testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml text eol=lf
+testsuite/tests/tool-toplevel/pr7060.ml text eol=lf
testsuite/tests/typing-extension-constructor/test.ml text eol=lf
testsuite/tests/typing-extensions/extensions.ml text eol=lf
testsuite/tests/typing-extensions/open_types.ml text eol=lf
*.out.dSYM
*.swp
_ocamltest
+_ocamltestd
+*.odoc
# local to root directory
/ocamldoc/ocamldoc
/ocamldoc/ocamldoc.opt
+/ocamldoc/odoc
/ocamldoc/odoc_crc.ml
/ocamldoc/odoc_lexer.ml
/ocamldoc/odoc_ocamlhtml.ml
/ocamldoc/odoc_text_parser.ml
/ocamldoc/odoc_text_parser.mli
/ocamldoc/stdlib_man
+/ocamldoc/stdlib_non_prefixed/*.mli
/ocamldoc/stdlib_html
/ocamldoc/*.output
/ocamldoc/test_stdlib
/otherlibs/dynlink/extract_crc
/otherlibs/threads/marshal.mli
-/otherlibs/threads/pervasives.mli
+/otherlibs/threads/stdlib.mli
/otherlibs/threads/unix.mli
/otherlibs/win32graph/graphics.ml
/otherlibs/win32graph/graphics.mli
/otherlibs/win32unix/strofaddr.c
/otherlibs/win32unix/time.c
/otherlibs/win32unix/unlink.c
-/otherlibs/win32unix/utimes.c
/parsing/parser.ml
/parsing/parser.mli
/testsuite/**/*.byte
/testsuite/**/*.native
/testsuite/**/program
-/testsuite/**/_log
+/testsuite/**/_log*
/testsuite/failure.stamp
/testsuite/_retries
-/testsuite/tests/asmcomp/codegen
-/testsuite/tests/asmcomp/parsecmm.ml
-/testsuite/tests/asmcomp/parsecmm.mli
-/testsuite/tests/asmcomp/lexcmm.ml
-/testsuite/tests/asmcomp/*.s
-/testsuite/tests/asmcomp/*.out.manifest
+/testsuite/tests/asmgen/codegen
+/testsuite/tests/asmgen/parsecmm.ml
+/testsuite/tests/asmgen/parsecmm.mli
+/testsuite/tests/asmgen/lexcmm.ml
+/testsuite/tests/asmgen/*.s
+/testsuite/tests/asmgen/*.out.manifest
-/testsuite/tests/basic/*.safe-string
/testsuite/tests/embedded/caml
-/testsuite/tests/float-unboxing/*.flambda
-/testsuite/tests/float-unboxing/float_inline.ml
-
/testsuite/tests/lib-dynlink-bytecode/main
/testsuite/tests/lib-dynlink-bytecode/static
/testsuite/tests/lib-dynlink-bytecode/custom
/testsuite/tests/lib-threads/*.byt
-/testsuite/tests/lib-unix/win-stat/*-file
-/testsuite/tests/lib-unix/win-symlink/link*
-/testsuite/tests/lib-unix/win-symlink/test.txt
-
-/testsuite/tests/lib-unix/win-symlink/link*
-/testsuite/tests/lib-unix/win-symlink/test.txt
-
-/testsuite/tests/opaque/*/*.mli
-
/testsuite/tests/output_obj/*.bc.c
/testsuite/tests/output_obj/*_stub
/testsuite/tests/output_obj/*_stub
/testsuite/tests/self-contained-toplevel/cached_cmi.ml
-/testsuite/tests/tool-debugger/**/compiler-libs
-/testsuite/tests/tool-debugger/find-artifacts/out
-/testsuite/tests/tool-debugger/no_debug_event/out
-/testsuite/tests/tool-debugger/no_debug_event/c
-
/testsuite/tests/tool-ocamldep-modalias/*.byt*
/testsuite/tests/tool-ocamldep-modalias/*.opt*
/testsuite/tests/tool-ocamldep-modalias/depend.mk
/testsuite/tests/tool-lexyacc/grammar.mli
/testsuite/tests/tool-lexyacc/grammar.ml
-/testsuite/tests/typing-misc/false.flat-float
-/testsuite/tests/typing-misc/true.flat-float
-/testsuite/tests/typing-misc/pr6939.ml
-
-/testsuite/tests/typing-multifile/a.ml
-/testsuite/tests/typing-multifile/b.ml
-/testsuite/tests/typing-multifile/c.ml
-/testsuite/tests/typing-multifile/d.mli
-/testsuite/tests/typing-multifile/e.ml
-/testsuite/tests/typing-multifile/f.ml
-/testsuite/tests/typing-multifile/g.ml
-/testsuite/tests/typing-multifile/test
-
/testsuite/tests/typing-unboxed-types/false.flat-float
/testsuite/tests/typing-unboxed-types/true.flat-float
/testsuite/tests/typing-unboxed-types/test.ml.reference
-/testsuite/tests/translprim/false.flat-float
-/testsuite/tests/translprim/true.flat-float
-/testsuite/tests/translprim/array_spec.ml.reference
-/testsuite/tests/translprim/module_coercion.ml.reference
-
/testsuite/tests/unboxed-primitive-args/main.ml
/testsuite/tests/unboxed-primitive-args/stubs.c
/testsuite/tests/unwind/unwind_test
-/testsuite/tests/warnings/w55.opt.opt_result
-/testsuite/tests/warnings/w58.opt.opt_result
-
/testsuite/tests/win-unicode/symlink_tests.precheck
/testsuite/tools/expect_test
Mohamed Iguernelala <mohamed.iguernelala@gmail.com>
Jérémie Dimino <jdimino@janestreet.com>
Jeremy Yallop <yallop@gmail.com> yallop <yallop@gmail.com>
+Nicolás Ojeda Bär <n.oje.bar@gmail.com>
# The aliases below correspond to preference expressed by
# contributors on the name under which they credited, for example
Junsong Li <lijunsong@mantis>
Junsong Li <ljs.darkfish@gmail.com>
Christophe Raffali <craff@mantis>
+Christophe Raffali <ChriChri@mantis>
Anton Bachin <antron@mantis>
Reed Wilson <omion>
David Scott <djs55>
Dwight Guth <dwightguth@github>
Andreas Hauptmann <andreashauptmann@t-online.de> fdopen <andreashauptmann@t-online.de>
Andreas Hauptmann <andreashauptmann@t-online.de> <fdopen@users.noreply.github.com>
+Andreas Hauptmann <andreashauptmann@t-online.de> <aha@mantis>
Hendrik Tews <hendrik@askra.de>
Hugo Heuzard <hugo.heuzard@gmail.com>
Miod Vallat <miod@mantis>
+Christoph Spiel <cspiel@mantis>
# These contributors prefer to be referred to pseudonymously
whitequark <whitequark@whitequark.org>
S ./otherlibs/graph
B ./otherlibs/graph
-S ./otherlibs/num
-B ./otherlibs/num
-
S ./otherlibs/str
B ./otherlibs/str
S ./parsing
B ./parsing
-S ./stdlib
-B ./stdlib
+STDLIB ./stdlib
+FLG -open Stdlib -nopervasives
S ./toplevel
B ./toplevel
+++ /dev/null
-#!/bin/bash
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Anil Madhavapeddy, OCaml Labs *
-#* *
-#* Copyright 2014 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-PREFIX=~/local
-
-MAKE=make SHELL=dash
-
-# TRAVIS_COMMIT_RANGE has the form <commit1>...<commit2>
-# TRAVIS_CUR_HEAD is <commit1>
-# TRAVIS_PR_HEAD is <commit2>
-#
-# The following diagram illustrates the relationship between
-# the commits:
-#
-# (trunk) (pr branch)
-# TRAVIS_CUR_HEAD TRAVIS_PR_HEAD
-# | /
-# ... ...
-# | /
-# TRAVIS_MERGE_BASE
-#
-echo TRAVIS_COMMIT_RANGE=$TRAVIS_COMMIT_RANGE
-TRAVIS_CUR_HEAD=${TRAVIS_COMMIT_RANGE%%...*}
-TRAVIS_PR_HEAD=${TRAVIS_COMMIT_RANGE##*...}
-case $TRAVIS_EVENT_TYPE in
- # If this is not a pull request then TRAVIS_COMMIT_RANGE may be empty.
- pull_request)
- TRAVIS_MERGE_BASE=$(git merge-base $TRAVIS_CUR_HEAD $TRAVIS_PR_HEAD);;
-esac
-
-BuildAndTest () {
- mkdir -p $PREFIX
- cat<<EOF
-------------------------------------------------------------------------
-This test builds the OCaml compiler distribution with your pull request
-and runs its testsuite.
-
-Failing to build the compiler distribution, or testsuite failures are
-critical errors that must be understood and fixed before your pull
-request can be merged.
-------------------------------------------------------------------------
-EOF
- case $XARCH in
- x64)
- ./configure --prefix $PREFIX -with-debug-runtime \
- -with-instrumented-runtime $CONFIG_ARG
- ;;
- i386)
- ./configure --prefix $PREFIX -with-debug-runtime \
- -with-instrumented-runtime $CONFIG_ARG \
- -host i686-pc-linux-gnu
- ;;
- *)
- echo unknown arch
- exit 1
- ;;
- esac
-
- export PATH=$PREFIX/bin:$PATH
- $MAKE world.opt
- $MAKE ocamlnat
- (cd testsuite && $MAKE all)
- [ $XARCH = "i386" ] || (cd testsuite && $MAKE USE_RUNTIME="d" all)
- $MAKE install
- $MAKE manual-pregen
- # check_all_arches checks tries to compile all backends in place,
- # we would need to redo (small parts of) world.opt afterwards to
- # use the compiler again
- $MAKE check_all_arches
-}
-
-CheckChangesModified () {
- cat<<EOF
-------------------------------------------------------------------------
-This test checks that the Changes file has been modified by the pull
-request. Most contributions should come with a message in the Changes
-file, as described in our contributor documentation:
-
- https://github.com/ocaml/ocaml/blob/trunk/CONTRIBUTING.md#changelog
-
-Some very minor changes (typo fixes for example) may not need
-a Changes entry. In this case, you may explicitly disable this test by
-adding the code word "No change entry needed" (on a single line) to
-a commit message of the PR, or using the "no-change-entry-needed" label
-on the github pull request.
-------------------------------------------------------------------------
-EOF
- # check that Changes has been modified
- git diff $TRAVIS_MERGE_BASE..$TRAVIS_PR_HEAD --name-only --exit-code Changes \
- > /dev/null && CheckNoChangesMessage || echo pass
-}
-
-CheckNoChangesMessage () {
- API_URL=https://api.github.com/repos/$TRAVIS_REPO_SLUG/issues/$TRAVIS_PULL_REQUEST/labels
- if test -n "$(git log --grep="[Nn]o [Cc]hange.* needed" --max-count=1 \
- ${TRAVIS_MERGE_BASE}..${TRAVIS_PR_HEAD})"
- then echo pass
- elif test -n "$(curl $API_URL | grep 'no-change-entry-needed')"
- then echo pass
- else exit 1
- fi
-}
-
-CheckTestsuiteModified () {
- cat<<EOF
-------------------------------------------------------------------------
-This test checks that the OCaml testsuite has been modified by the
-pull request. Any new feature should come with tests, bugs should come
-with regression tests, and generally any change in behavior that can
-be exercised by a test should come with a test or modify and existing
-test. See our contributor documentation:
-
- https://github.com/ocaml/ocaml/blob/trunk/CONTRIBUTING.md#test-you-must
-
-Modifications that result in no change in observable behavior
-(documentation contributions for example) can hardly be tested, in
-which case it is acceptable for this test to fail.
-
-Note: the heuristic used by this test is extremely fragile; passing it
-does *not* imply that your change is appropriately tested.
-------------------------------------------------------------------------
-EOF
- # check that at least a file in testsuite/ has been modified
- git diff $TRAVIS_MERGE_BASE..$TRAVIS_PR_HEAD --name-only --exit-code \
- testsuite > /dev/null && exit 1 || echo pass
-}
-
-case $CI_KIND in
-build) BuildAndTest;;
-changes)
- case $TRAVIS_EVENT_TYPE in
- pull_request) CheckChangesModified;;
- esac;;
-tests)
- case $TRAVIS_EVENT_TYPE in
- pull_request) CheckTestsuiteModified;;
- esac;;
-*) echo unknown CI kind
- exit 1
- ;;
-esac
language: c
git:
submodules: false
-script: bash -ex .travis-ci.sh
+script: bash -ex tools/ci/travis/travis-ci.sh
matrix:
include:
- env: CI_KIND=build XARCH=i386
+OCaml 4.07.0 (10 July 2018)
+---------------------------
+
+(Changes that can break existing programs are marked with a "*")
+
+### Language features:
+
+- MPR#6023, GPR#1648: Allow type-based selection of GADT constructors
+ (Thomas Refis and Leo White, review by Jacques Garrigue and Gabriel Scherer)
+
+- GPR#1546: Allow empty variants
+ (Runhang Li, review by Gabriel Radanne and Jacques Garrigue)
+
+### Standard library:
+
+- MPR#4170, GPR#1674: add the constant `Float.pi`.
+ (Christophe Troestler, review by Damien Doligez)
+
+- MPR#6139, GPR#1685: Move the Bigarray module to the standard library. Keep the
+ bigarray library as on overlay adding the deprecated map_file functions
+ (Jérémie Dimino, review by Mark Shinwell)
+
+- MPR#7690, GPR#1528: fix the float_of_string function for hexadecimal floats
+ with very large values of the exponent.
+ (Olivier Andrieu)
+
+- GPR#1002: add a new `Seq` module defining a list-of-thunks style iterator.
+ Also add `{to,of}_seq` to several standard modules.
+ (Simon Cruanes, review by Alain Frisch and François Bobot)
+
+* GPR#1010: pack all standard library modules into a single module Stdlib
+ which is the default opened module (Stdlib itself includes Pervasives) to free
+ up the global namespace for other standard libraries, while still allowing any
+ OCaml standard library module to be referred to as Stdlib.Module). This is
+ implemented efficiently using module aliases (prefixing all modules with
+ Stdlib__, e.g. Stdlib__string).
+ (Jérémie Dimino, David Allsopp and Florian Angeletti, review by David Allsopp
+ and Gabriel Radanne)
+
+- GPR#1637: String.escaped is faster and does not allocate when called with a
+ string that does not contain any characters needing to be escaped.
+ (Alain Frisch, review by Xavier Leroy and Gabriel Scherer)
+
+- GPR#1638: add a Float module.
+ (Nicolás Ojeda Bär, review by Alain Frisch and Jeremy Yallop)
+
+- GPR#1697: Tune [List.init] tailrec threshold so that it does not stack overflow
+ when compiled with the Js_of_ocaml backend.
+ (Hugo Heuzard, reviewed by Gabriel Scherer)
+
+### Other libraries:
+
+- MPR#7745, GPR#1629: Graphics.open_graph displays the correct window title on
+ Windows again (fault introduced by 4.06 Unicode changes).
+ (David Allsopp)
+
+* GPR#1406: Unix.isatty now returns true in the native Windows ports when
+ passed a file descriptor connected to a Cygwin PTY. In particular, compiler
+ colors for the native Windows ports now work under Cygwin/MSYS2.
+ (Nicolás Ojeda Bär, review by Gabriel Scherer, David Allsopp, Xavier Leroy)
+
+- GPR#1451: [getpwuid], [getgrgid], [getpwnam], [getgrnam] now raise Unix error
+ instead of returning [Not_found] when interrupted by a signal.
+ (Arseniy Alekseyev, review by Mark Shinwell and Xavier Leroy)
+
+- GPR#1477: raw_spacetime_lib can now be used in bytecode.
+ (Nicolás Ojeda Bär, review by Mark Shinwell)
+
+- GPR#1533: (a) The implementation of Thread.yield for system thread
+ now uses nanosleep(1) for enabling better preemption.
+ (b) Thread.delay is now an alias for Unix.sleepf.
+ (Jacques-Henri Jourdan, review by Xavier Leroy and David Allsopp)
+
+### Compiler user-interface and warnings:
+
+- MPR#7663, GPR#1694: print the whole cycle and add a reference to the manual in
+ the unsafe recursive module evaluation error message.
+ (Florian Angeletti, report by Matej Košík, review by Gabriel Scherer)
+
+- GPR#1166: In OCAMLPARAM, an alternative separator can be specified as
+ first character (instead of comma) in the set ":|; ,"
+ (Fabrice Le Fessant)
+
+- GPR#1358: Fix usage warnings with no mli file
+ (Leo White, review by Alain Frisch)
+
+- GPR#1428: give a non dummy location for warning 49 (no cmi found)
+ (Valentin Gatien-Baron)
+
+- GPR#1491: Improve error reporting for ill-typed applicative functor
+ types, F(M).t.
+ (Valentin Gatien-Baron, review by Florian Angeletti and Gabriel Radanne)
+
+- GPR#1496: Refactor the code printing explanation for unification type errors,
+ in order to avoid duplicating pattern matches
+ (Armaël Guéneau, review by Florian Angeletti and Gabriel Scherer)
+
+- GPR#1505: Add specific error messages for unification errors involving
+ functions of type "unit -> _"
+ (Arthur Charguéraud and Armaël Guéneau, with help from Leo White, review by
+ Florian Angeletti and Gabriel Radanne)
+
+- GPR#1510: Add specific explanation for unification errors caused by type
+ constraints propagated by keywords (such as if, while, for...)
+ (Armaël Guéneau and Gabriel Scherer, original design by Arthur Charguéraud,
+ review by Frédéric Bour, Gabriel Radanne and Alain Frisch)
+
+- GPR#1515: honor the BUILD_PATH_PREFIX_MAP environment variable
+ to enable reproducible builds
+ (Gabriel Scherer, with help from Ximin Luo, review by Damien Doligez)
+
+- GPR#1534: Extend the warning printed when (*) is used, adding a hint to
+ suggest using ( * ) instead
+ (Armaël Guéneau, with help and review from Florian Angeletti and Gabriel
+ Scherer)
+
+- GPR#1552, GPR#1577: do not warn about ambiguous variables in guards
+ (warning 57) when the ambiguous values have been filtered by
+ a previous clause
+ (Gabriel Scherer and Thomas Refis, review by Luc Maranget)
+
+- GPR#1554: warnings 52 and 57: fix reference to manual detailed explanation
+ (Florian Angeletti, review by Thomas Refis and Gabriel Scherer)
+
+- GPR#1618: add the -dno-unique-ids and -dunique-ids compiler flags
+ (Sébastien Hinderer, review by Leo White and Damien Doligez)
+
+- GPR#1649 change compilation order of toplevel definitions, so that some warnings
+ emitted by the bytecode compiler appear more in-order than before.
+ (Luc Maranget, advice and review by Damien Doligez)
+
+- GPR#1806: add linscan to OCAMLPARAM options
+ (Raja Boujbel)
+
+### Code generation and optimizations:
+
+- MPR#7630, GPR#1401: Faster compilation of large modules with Flambda.
+ (Pierre Chambart, report by Emilio Jesús Gallego Arias,
+ Pierre-Marie Pédrot and Paul Steckler, review by Gabriel Scherer
+ and Leo White)
+
+- MPR#7630, GPR#1455: Disable CSE for the initialization function
+ (Pierre Chambart, report by Emilio Jesús Gallego Arias,
+ review by Gabriel Scherer and Xavier Leroy)
+
+- GPR#1370: Fix code duplication in Cmmgen
+ (Vincent Laviron, with help from Pierre Chambart,
+ reviews by Gabriel Scherer and Luc Maranget)
+
+- GPR#1486: ARM 32-bit port: add support for ARMv8 in 32-bit mode,
+ a.k.a. AArch32.
+ For this platform, avoid ITE conditional instruction blocks and use
+ simpler IT blocks instead
+ (Xavier Leroy, review by Mark Shinwell)
+
+- GPR#1487: Treat negated float comparisons more directly
+ (Leo White, review by Xavier Leroy)
+
+- GPR#1573: emitcode: merge events after instructions reordering
+ (Thomas Refis and Leo White, with help from David Allsopp, review by Frédéric
+ Bour)
+
+- GPR#1606: Simplify the semantics of Lambda.free_variables and Lambda.subst,
+ including some API changes in bytecomp/lambda.mli
+ (Pierre Chambart, review by Gabriel Scherer)
+
+- GPR#1613: ensure that set-of-closures are processed first so that other
+ entries in the let-rec symbol do not get dummy approximations
+ (Leo White and Xavier Clerc, review by Pierre Chambart)
+
+* GPR#1617: Make string/bytes distinguishable in the bytecode.
+ (Hugo Heuzard, reviewed by Nicolás Ojeda Bär)
+
+- GPR#1627: Reduce cmx sizes by sharing variable names (Flambda only)
+ (Fuyong Quah, Leo White, review by Xavier Clerc)
+
+- GPR#1665: reduce the size of cmx files in classic mode by droping the
+ bodies of functions that will not be inlined
+ (Fuyong Quah, review by Leo White and Pierre Chambart)
+
+- GPR#1666: reduce the size of cmx files in classic mode by droping the
+ bodies of functions that cannot be reached from the module block
+ (Fuyong Quah, review by Leo White and Pierre Chambart)
+
+- GPR#1686: Turn off by default flambda invariants checks.
+ (Pierre Chambart)
+
+- GPR#1707: Add [Closure_origin.t] to trace inlined functions to prevent
+ infinite loops from repeatedly inlining copies of the same function.
+ (Fu Yong Quah)
+
+- GPR#1740: make sure startup.o is always linked in when using
+ "-output-complete-obj". Previously, it was always linked in only on some
+ platforms, making this option unusable on platforms where it wasn't
+ (Jérémie Dimino, review by Sébastien Hinderer and Xavier Leroy)
+
+### Runtime system:
+
+- MPR#6411, GPR#1535: don't compile everything with -static-libgcc on mingw32,
+ only dllbigarray.dll and libbigarray.a. Allows the use of C++ libraries which
+ raise exceptions.
+ (David Allsopp)
+
+- MPR#7100, GPR#1476: trigger a minor GC when custom blocks accumulate
+ in minor heap
+ (Alain Frisch, report by talex, review by Damien Doligez, Leo White,
+ Gabriel Scherer)
+
+- GPR#1431: remove ocamlrun dependencies on curses/terminfo/termcap C library
+ (Xavier Leroy, review by Daniel Bünzli)
+
+- GPR#1478: The Spacetime profiler now works under Windows (but it is not yet
+ able to collect profiling information from C stubs).
+ (Nicolás Ojeda Bär, review by Xavier Leroy, Mark Shinwell)
+
+- GPR#1483: fix GC freelist accounting for chunks larger than the maximum block
+ size.
+ (David Allsopp and Damien Doligez)
+
+- GPR#1526: install the debug and instrumented runtimes
+ (lib{caml,asm}run{d,i}.a)
+ (Gabriel Scherer, reminded by Julia Lawall)
+
+- GPR#1563: simplify implementation of LSRINT and ASRINT
+ (Max Mouratov, review by Frédéric Bour)
+
+- GPR#1644: remove caml_alloc_float_array from the bytecode primitives list
+ (it's a native code primitive)
+ (David Allsopp)
+
+- GPR#1701: fix missing root bug in GPR#1476
+ (Mark Shinwell)
+
+- GPR#1752: do not alias function arguments to sigprocmask (Anil Madhavapeddy)
+
+- GPR#1753: avoid potential off-by-one overflow in debugger socket path
+ length (Anil Madhavapeddy)
+
+### Tools:
+
+- MPR#7643, GPR#1377: ocamldep, fix an exponential blowup in presence of nested
+ structures and signatures (e.g. "include struct … include(struct … end) … end")
+ (Florian Angeletti, review by Gabriel Scherer, report by Christophe Raffalli)
+
+- MPR#7687, GPR#1653: deprecate -thread option,
+ which is equivalent to -I +threads.
+ (Nicolás Ojeda Bär, report by Daniel Bünzli)
+
+- MPR#7710: `ocamldep -sort` should exit with nonzero code in case of
+ cyclic dependencies
+ (Xavier Leroy, report by Mantis user baileyparker)
+
+- GPR#1537: boot/ocamldep is no longer included in the source distribution;
+ boot/ocamlc -depend can be used in its place.
+ (Nicolás Ojeda Bär, review by Xavier Leroy and Damien Doligez)
+
+- GPR#1585: optimize output of "ocamllex -ml"
+ (Alain Frisch, review by Frédéric Bour and Gabriel Scherer)
+
+- GPR#1667: add command-line options -no-propt, -no-version, -no-time,
+ -no-breakpoint and -topdirs-path to ocamldebug
+ (Sébastien Hinderer, review by Damien Doligez)
+
+- GPR#1695: add the -null-crc command-line option to ocamlobjinfo.
+ (Sébastien Hinderer, review by David Allsopp and Gabriel Scherer)
+
+- GPR#1710: ocamldoc, improve the 'man' rendering of subscripts and
+ superscripts.
+ (Gabriel Scherer)
+
+- GPR#1771: ocamdebug, avoid out of bound access
+ (Thomas Refis)
+
+### Manual and documentation:
+
+- MPR#7613: minor reword of the "refutation cases" paragraph
+ (Florian Angeletti, review by Jacques Garrigue)
+
+- PR#7647, GPR#1384: emphasize ocaml.org website and forum in README
+ (Yawar Amin, review by Gabriel Scherer)
+
+- PR#7698, GPR#1545: improve wording in OCaml manual in several places,
+ mostly in Chapter 1. This addresses the easier changes suggested in the PR.
+ (Jim Fehrle, review by Florian Angeletti and David Allsopp)
+
+- GPR#1540: manual, decouple verbatim and toplevel style in code examples
+ (Florian Angeletti, review by Gabriel Scherer)
+
+- GPR#1556: manual, add a consistency test for manual references inside
+ the compiler source code.
+ (Florian Angeletti, review by Gabriel Scherer)
+
+- GPR#1647: manual, subsection on record and variant disambiguation
+ (Florian Angeletti, review by Alain Frisch and Gabriel Scherer)
+
+- GPR#1702: manual, add a signature mode for code examples
+ (Florian Angeletti, review by Gabriel Scherer)
+
+- GPR#1741: manual, improve typesetting and legibility in HTML output
+ (steinuil, review by Gabriel Scherer)
+
+- GPR#1757: style the html manual, changing type and layout
+ (Charles Chamberlain, review by Florian Angeletti, Xavier Leroy,
+ Gabriel Radanne, Perry E. Metzger, and Gabriel Scherer)
+
+- GPR#1765: manual, ellipsis in code examples
+ (Florian Angeletti, review and suggestion by Gabriel Scherer)
+
+- GPR#1767: change html manual to use relative font sizes
+ (Charles Chamberlain, review by Daniel Bünzli, Perry E. Metzger,
+ Josh Berdine, and Gabriel Scherer)
+
+- GPR#1779: integrate the Bigarray documentation into the main manual.
+ (Perry E. Metzger, review by Florian Angeletti and Xavier Clerc)
+
+### Type system:
+
+- MPR#7611, GPR#1491: reject the use of generative functors as applicative
+ (Valentin Gatien-Baron)
+
+- MPR#7706, GPR#1565: in recursive value declarations, track
+ static size of locally-defined variables
+ (Gabriel Scherer, review by Jeremy Yallop and Leo White, report by Leo White)
+
+- MPR#7717, GPR#1593: in recursive value declarations, don't treat
+ unboxed constructor size as statically known
+ (Jeremy Yallop, report by Pierre Chambart, review by Gabriel Scherer)
+
+- MPR#7767, GPR#1712: restore legacy treatment of partially-applied
+ labeled functions in 'let rec' bindings.
+ (Jeremy Yallop, report by Ivan Gotovchits, review by Gabriel Scherer)
+
+* MPR#7787, GPR#1652, GPR#1743: Don't remove module aliases in `module type of`
+ and `with module`.
+ The old behaviour can be obtained using the `[@remove_aliases]` attribute.
+ (Leo White and Thomas Refis, review by Jacques Garrigue)
+
+- GPR#1468: Do not enrich type_decls with incoherent manifests
+ (Thomas Refis and Leo White, review by Jacques Garrigue)
+
+- GPR#1469: Use the information from [@@immediate] annotations when
+ computing whether a type can be [@@unboxed]
+ (Damien Doligez, report by Stephan Muenzel, review by Alain Frisch)
+
+- GPR#1513: Allow compilation units to shadow sub-modules of Pervasives.
+ For instance users can now use a largeFile.ml file in their project.
+ (Jérémie Dimino, review by Nicolas Ojeda Bar, Alain Frisch and Gabriel Radanne)
+
+- GPR#1516: Allow float array construction in recursive bindings
+ when configured with -no-flat-float-array
+ (Jeremy Yallop, report by Gabriel Scherer)
+
+- GPR#1583: propagate refined ty_arg to Parmatch checks
+ (Thomas Refis, review by Jacques Garrigue)
+
+- GPR#1609: Changes to ambivalence scope tracking
+ (Thomas Refis and Leo White, review by Jacques Garrigue)
+
+- GPR#1628: Treat reraise and raise_notrace as nonexpansive.
+ (Leo White, review by Alain Frisch)
+
+* GPR#1778: Fix Soundness bug with non-generalized type variable and
+ local modules. This is the same bug as MPR#7414, but using local
+ modules instead of non-local ones.
+ (Leo White, review by Jacques Garrigue)
+
+### Compiler distribution build system
+
+- MPR#5219, GPR#1680, GPR#1877: use 'install' instead of 'cp'
+ in install scripts.
+ (Gabriel Scherer, review by Sébastien Hinderer and Valentin Gatien-Baron)
+
+- MPR#7679: make sure .a files are erased before calling ar rc, otherwise
+ leftover .a files from an earlier compilation may contain unwanted modules
+ (Xavier Leroy)
+
+- GPR#1571: do not perform architecture tests on 32-bit platforms, allowing
+ 64-bit back-ends to use 64-bit specific constructs
+ (Xavier Clerc, review by Damien Doligez)
+
+### Internal/compiler-libs changes:
+
+- MPR#7738, GPR#1624: Asmlink.reset also resets lib_ccobjs/ccopts
+ (Cedric Cellier, review by Gabriel Scherer)
+
+- GPR#1488, GPR#1560: Refreshing parmatch
+ (Gabriel Scherer and Thomas Refis, review by Luc Maranget)
+
+- GPR#1502: more command line options for expect tests
+ (Florian Angeletti, review by Gabriel Scherer)
+
+- GPR#1511: show code at error location in expect-style tests,
+ using new Location.show_code_at_location function
+ (Gabriel Scherer and Armaël Guéneau,
+ review by Valentin Gatien-Baron and Damien Doligez)
+
+- GPR#1519, GPR#1532, GRP#1570: migrate tests to ocamltest
+ (Sébastien Hinderer, review by Gabriel Scherer, Valentin Gatien-Baron
+ and Nicolás Ojeda Bär)
+
+- GPR#1520: more robust implementation of Misc.no_overflow_mul
+ (Max Mouratov, review by Xavier Leroy)
+
+- GPR#1557: Organise and simplify translation of primitives
+ (Leo White, review by François Bobot and Nicolás Ojeda Bär)
+
+- GPR#1567: register all idents relevant for reraise
+ (Thomas Refis, review by Alain Frisch and Frédéric Bour)
+
+- GPR#1586: testsuite: 'make promote' for ocamltest tests
+ (The new "-promote" option for ocamltest is experimental
+ and subject to change/removal).
+ (Gabriel Scherer)
+
+- GPR#1619: expect_test: print all the exceptions, even the unexpected ones
+ (Thomas Refis, review by Jérémie Dimino)
+
+- GPR#1621: expect_test: make sure to not use the installed stdlib
+ (Jérémie Dimino, review by Thomas Refis)
+
+- GPR#1646 : add ocamldoc test to ocamltest and
+ migrate ocamldoc tests to ocamltest
+ (Florian Angeletti, review by Sébastien Hinderer)
+
+- GPR#1663: refactor flambda specialise/inlining handling
+ (Leo White and Xavier Clerc, review by Pierre Chambart)
+
+- GPR#1679 : remove Pbittest from primitives in lambda
+ (Hugo Heuzard, review by Mark Shinwell)
+
+* GPR#1704: Make Ident.t abstract and immutable.
+ (Gabriel Radanne, review by Mark Shinwell)
+
+### Bug fixes
+
+- MPR#4499, GPR#1479: Use native Windows API to implement Sys.getenv,
+ Unix.getenv and Unix.environment under Windows.
+ (Nicolás Ojeda Bär, report by Alain Frisch, review by David Allsopp, Xavier
+ Leroy)
+
+- MPR#5250, GPR#1435: on Cygwin, when ocamlrun searches the path
+ for a bytecode executable file, skip directories and other
+ non-regular files, like other Unix variants do.
+ (Xavier Leroy)
+
+- MPR#6394, GPR#1425: fix fatal_error from Parmatch.get_type_path
+ (Virgile Prevosto, review by David Allsopp, Thomas Refis and Jacques Garrigue)
+
+* MPR#6604, GPR#931: Only allow directives with filename and at the beginning of
+ the line
+ (Tadeu Zagallo, report by Roberto Di Cosmo,
+ review by Hongbo Zhang, David Allsopp, Gabriel Scherer, Xavier Leroy)
+
+- MPR#7138, MPR#7701, GPR#1693: Keep documentation comments
+ even in empty structures and signatures
+ (Leo White, Florian Angeletti, report by Anton Bachin)
+
+- MPR#7178, MPR#7253, MPR#7796, GPR#1790: Make sure a function
+ registered with "at_exit" is executed only once when the program exits
+ (Nicolás Ojeda Bär and Xavier Leroy, review by Max Mouratov)
+
+- MPR#7391, GPR#1620: Do not put a dummy method in object types
+ (Thomas Refis, review by Jacques Garrigue)
+
+- PR#7660, GPR#1445: Use native Windows API to implement Unix.utimes in order to
+ avoid unintended shifts of the argument timestamp depending on DST setting.
+ (Nicolás Ojeda Bär, review by David Allsopp, Xavier Leroy)
+
+- MPR#7668: -principal is broken with polymorphic variants
+ (Jacques Garrigue, report by Jun Furuse)
+
+- MPR#7680, GPR#1497: Incorrect interaction between Matching.for_let and
+ Simplif.simplify_exits
+ (Alain Frisch, report and review by Vincent Laviron)
+
+- MPR#7682, GPR#1495: fix [@@unboxed] for records with 1 polymorphic field
+ (Alain Frisch, report by Stéphane Graham-Lengrand, review by Gabriel Scherer)
+
+- MPR#7695, GPR#1541: Fatal error: exception Ctype.Unify(_) with field override
+ (Jacques Garrigue, report by Nicolás Ojeda Bär)
+
+- MPR#7704, GPR#1564: use proper variant tag in non-exhaustiveness warning
+ (Jacques Garrigue, report by Thomas Refis)
+
+- MPR#7711, GPR#1581: Internal typechecker error triggered by a constraint on
+ self type in a class type
+ (Jacques Garrigue, report and review by Florian Angeletti)
+
+- MPR#7712, GPR#1576: assertion failure with type abbreviations
+ (Thomas Refis, report by Michael O'Connor, review by Jacques Garrigue)
+
+- MPR#7747: Type checker can loop infinitly and consumes all computer memory
+ (Jacques Garrigue, report by kantian)
+
+- MPR#7751, GPR#1657: The toplevel prints some concrete types as abstract
+ (Jacques Garrigue, report by Matej Kosik)
+
+- MPR#7765, GPR#1718: When unmarshaling bigarrays, protect against integer
+ overflows in size computations
+ (Xavier Leroy, report by Maximilian Tschirschnitz,
+ review by Gabriel Scherer)
+
+- MPR#7760, GPR#1713: Exact selection of lexing engine, that is
+ correct "Segfault in ocamllex-generated code using 'shortest'"
+ (Luc Maranget, Frédéric Bour, report by Stephen Dolan,
+ review by Gabriel Scherer)
+
+- MPR#7769, GPR#1714: calls to Stream.junk could, under some conditions, be
+ ignored when used on streams based on input channels.
+ (Nicolás Ojeda Bär, report by Michael Perin, review by Gabriel Scherer)
+
+- MPR#7793, GPR#1766: the toplevel #use directive now accepts sequences of ';;'
+ tokens. This fixes a bug in which certain files accepted by the compiler were
+ rejected by ocamldep.
+ (Nicolás Ojeda Bär, report by Hugo Heuzard, review by Hugo Heuzard)
+
+- GPR#1517: More robust handling of type variables in mcomp
+ (Leo White and Thomas Refis, review by Jacques Garrigue)
+
+- GPR#1530, GPR#1574: testsuite, fix 'make parallel' and 'make one DIR=...'
+ to work on ocamltest-based tests.
+ (Runhang Li and Sébastien Hinderer, review by Gabriel Scherer)
+
+- GPR#1550, GPR#1555: Make pattern matching warnings more robust
+ to ill-typed columns
+ (Thomas Refis, with help from Gabriel Scherer and Luc Maranget)
+
+- GPR#1614: consider all bound variables when inlining, fixing a compiler
+ fatal error.
+ (Xavier Clerc, review by Pierre Chambart, Leo White)
+
+- GPR#1622: fix bug in the expansion of command-line arguments under Windows
+ which could result in some elements of Sys.argv being truncated in some cases.
+ (Nicolás Ojeda Bär, review by Sébastien Hinderer)
+
+- GPR#1623: Segfault on Windows 64 bits when expanding wildcards in arguments.
+ (Marc Lasson, review by David Allsopp, Alain Frisch, Sébastien Hinderer,
+ Xavier Leroy, Nicolas Ojeda Bar)
+
+- GPR#1661: more precise principality warning regarding record fields
+ disambiguation
+ (Thomas Refis, review by Leo White)
+
+- GPR#1687: fix bug in the printing of short functor types "(S1 -> S2) -> S3"
+ (Pieter Goetschalckx, review by Gabriel Scherer)
+
+- GPR#1722: Scrape types in Typeopt.maybe_pointer
+ (Leo White, review by Thomas Refis)
+
+- GPR#1755: ensure that a bigarray is never collected while reading complex
+ values (Xavier Clerc, Mark Shinwell and Leo White, report by Chris Hardin,
+ reviews by Stephen Dolan and Xavier Leroy)
+
+- GPR#1764: in byterun/memory.c, struct pool_block, use C99 flexible arrays
+ if available
+ (Xavier Leroy, review by Max Mouratov)
+
+- GPR#1774: ocamlopt for ARM could generate VFP loads and stores with bad
+ offsets, rejected by the assembler.
+ (Xavier Leroy, review by Mark Shinwell)
+
+- GPR#1808: handle `[@inlined]` attributes under a module constraint
+ (Xavier Clerc, review by Leo White)
+
+- GPR#1810: use bit-pattern comparison when meeting float approximations
+ (Xavier Clerc, report by Christophe Troestler, review by Nicolás Ojeda Bär
+ and Gabriel Scherer)
+
+- GPR#1835: Fix off-by-one errors in Weak.get_copy and Weak.blit
+ (KC Sivaramakrishnan)
+
+- GPR#1849: bug in runtime function generic_final_minor_update()
+ that could lead to crashes when Gc.finalise_last is used
+ (report and fix by Yuriy Vostrikov, review by François Bobot)
+
+
OCaml 4.06.1 (16 Feb 2018):
---------------------------
(Florian Angeletti, review by Daniel Bünzli, Xavier Leroy and
Gabriel Scherer)
+- GPR#1688: Fix printing of -0.
+ (Nicolás Ojeda Bär, review by Jérémie Dimino)
+
### Runtime system:
* MPR#3771, GPR#153, GPR#1200, GPR#1357, GPR#1362, GPR#1363, GPR#1369, GPR#1398,
==== Github's CI: Travis and AppVeyor
The script that is run on Travis continuous integration servers is
-link:.travis-ci.sh[]; its configuration can be found as
+link:tools/ci/travis/travis-ci.sh[]; its configuration can be found as
a Travis configuration file in link:.travis.yml[].
For example, if you want to reproduce the default build on your
link:.travis.yml[]:
----
-CI_KIND=build XARCH=x64 bash -ex .travis-ci.sh
+CI_KIND=build XARCH=x64 bash -ex tools/ci/travis/travis-ci.sh
----
The scripts support two other kinds of tests (values of the
jenkins service; anyone can create an account there to access build
logs and manually restart builds. If you
would like to do this but have trouble doing it, please email
-ocaml-ci-admin@inria.fr
+ocaml-ci-admin@inria.fr.
To be notified by email of build failures, you can subscribe to the
ocaml-ci-notifications@inria.fr mailing list by visiting
-https://sympa.inria.fr/sympa/info/ocaml-ci-notifications[its web page]
+https://sympa.inria.fr/sympa/info/ocaml-ci-notifications[its web page.]
==== Running INRIA's CI on a publicly available git branch
7. You should receive a bunch of e-mails with the build logs for each
slave and each tested configuration (with and without flambda) attached.
+==== Changing what the CI does
+
+INRIA's CI "main" and "precheck" jobs run the script
+tools/ci-build. In particular, when running the CI on a publicly
+available branch via the "precheck" job as explained in the previous
+section, you can edit this script to change what the CI will test.
+
+For instance, parallel builds are only tested for the "trunk"
+branch. In order to use "precheck" to test parallel build on a custom
+branch, add this at the beginning of tools/ci-build:
+
+----
+OCAML_JOBS=10
+----
+
+=== The `caml-commits` mailing list
+
+If you would like to receive email notifications of all commits made to the main
+git repository, you can subscribe to the caml-commits@inria.fr mailing list by
+visiting https://sympa.inria.fr/sympa/info/caml-commits[its web page.]
+
Happy Hacking!
2. From the top directory, do:
+ make world.opt
++
+if your platform is supported by the native-code compiler (as reported during
+ the auto-configuration), or
+
make world
+
+if not.
+
This builds the OCaml bytecode compiler for the first time. This phase is
fairly verbose; consider redirecting the output to a file:
`make bootstrap` again. It will either crash almost immediately, or
re-re-compile everything correctly and reach the fix-point.
-4. If your platform is supported by the native-code compiler (as reported during
- the auto-configuration), you can now build the native-code compiler. From
- the top directory, do:
-
- make opt
-+
-or:
-
- make opt > log.opt 2>&1 # in sh
- make opt >& log.opt # in csh
-
-5. anchor:step-5[] Compile fast versions of the OCaml compilers, by compiling
- them with the native-code compiler (you will have only compiled them to
- bytecode in steps 2-4). Just do:
-
- make opt.opt
-+
-Later, you can compile your programs to bytecode using ocamlc.opt instead of
-ocamlc, and to native-code using ocamlopt.opt instead of ocamlopt. The ".opt"
-compilers should run faster than the normal compilers, especially on large input
-files, but they may take longer to start due to increased code size. If
-compilation times are an issue on your programs, try the ".opt" compilers to see
-if they make a significant difference.
-+
-An alternative, and faster approach to steps 2 to 5 is
-
- make world.opt # to build using native-code compilers
-+
-The result is equivalent to `make world opt opt.opt`, but this may fail if
-anything goes wrong in native-code generation.
-
-6. You can now install the OCaml system. This will create the following commands
+4. You can now install the OCaml system. This will create the following commands
(in the binary directory selected during autoconfiguration):
+
[width="70%",frame="topbot",cols="25%,75%"]
| `ocamlcp` | the bytecode compiler in profiling mode
|===============================================================================
+
-and also, if you built them during <<step-5,step 5>>: `ocamlc.opt`,
-`ocamlopt.opt`, `ocamllex.opt`, `ocamldep.opt` and `ocamldoc.opt`
-+
From the top directory, become superuser and do:
umask 022 # make sure to give read & execute permission to all
make install
-7. Installation is complete. Time to clean up. From the toplevel directory,
+5. Installation is complete. Time to clean up. From the toplevel directory,
do:
make clean
-8. (Optional) The `emacs/` subdirectory contains Emacs-Lisp files for an OCaml
+6. (Optional) The `emacs/` subdirectory contains Emacs-Lisp files for an OCaml
editing mode and an interface for the debugger. To install these files,
change to the `emacs/` subdirectory and do:
In the latter case, the destination directory defaults to the
`site-lisp` directory of your Emacs installation.
-9. After installation, do *not* strip the `ocamldebug` and `ocamlbrowser`
+7. After installation, do *not* strip the `ocamldebug` and `ocamlbrowser`
executables. These are mixed-mode executables (containing both compiled C
code and OCaml bytecode) and stripping erases the bytecode! Other
executables such as `ocamlrun` can safely be stripped.
# The main Makefile
# Hard bootstrap how-to:
-# (only necessary in some cases, for example if you remove some primitive)
+# (only necessary if you remove or rename some primitive)
#
-# make coreboot [old system -- you were in a stable state]
-# <change the source>
-# make clean runtime coreall
-# <debug your changes>
-# make clean runtime coreall
+# make core [old system -- you were in a stable state]
+# make coreboot [optional -- check state stability]
+# <add new primitives and remove uses of old primitives>
+# make clean && make core
+# if the above fails:
+# <debug your changes>
+# make clean && make core
+# make coreboot [intermediate state with both old and new primitives]
+# <remove old primitives>
+# make clean && make runtime && make coreall
# make coreboot [new system -- now in a stable state]
include config/Makefile
+include Makefile.common
# For users who don't read the INSTALL file
.PHONY: defaultentry
YACCFLAGS=-v --strict
CAMLLEX=$(CAMLRUN) boot/ocamllex
-CAMLDEP=$(CAMLRUN) tools/ocamldep
+CAMLDEP=$(CAMLRUN) boot/ocamlc -depend
DEPFLAGS=$(INCLUDES)
OCAMLDOC_OPT=$(WITH_OCAMLDOC:=.opt)
utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
utils/consistbl.cmo \
utils/strongly_connected_components.cmo \
+ utils/build_path_prefix_map.cmo \
utils/targetint.cmo
PARSING=parsing/location.cmo parsing/longident.cmo \
typing/typedtreeIter.cmo typing/typedtreeMap.cmo \
typing/tast_mapper.cmo \
typing/cmt_format.cmo typing/untypeast.cmo \
- typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
- typing/stypes.cmo typing/typedecl.cmo typing/typeopt.cmo typing/typecore.cmo \
- typing/typeclass.cmo \
- typing/typemod.cmo
+ typing/includemod.cmo typing/typetexp.cmo typing/printpat.cmo \
+ typing/parmatch.cmo typing/stypes.cmo typing/typedecl.cmo typing/typeopt.cmo \
+ typing/typecore.cmo typing/typeclass.cmo typing/typemod.cmo
COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
bytecomp/semantics_of_primitives.cmo \
bytecomp/switch.cmo bytecomp/matching.cmo \
bytecomp/translobj.cmo bytecomp/translattribute.cmo \
- bytecomp/translcore.cmo \
+ bytecomp/translprim.cmo bytecomp/translcore.cmo \
bytecomp/translclass.cmo bytecomp/translmod.cmo \
bytecomp/simplif.cmo bytecomp/runtimedef.cmo \
bytecomp/meta.cmo bytecomp/opcodes.cmo \
asmcomp/export_info_for_pack.cmo \
asmcomp/compilenv.cmo \
asmcomp/closure.cmo \
+ asmcomp/traverse_for_exported_symbols.cmo \
asmcomp/build_export_info.cmo \
asmcomp/closure_offsets.cmo \
asmcomp/flambda_to_clambda.cmo \
middle_end/base_types/tag.cmo \
middle_end/base_types/linkage_name.cmo \
middle_end/base_types/compilation_unit.cmo \
+ middle_end/internal_variable_names.cmo \
middle_end/base_types/variable.cmo \
middle_end/base_types/mutable_variable.cmo \
middle_end/base_types/id_types.cmo \
middle_end/base_types/set_of_closures_origin.cmo \
middle_end/base_types/closure_element.cmo \
middle_end/base_types/closure_id.cmo \
+ middle_end/base_types/closure_origin.cmo \
middle_end/base_types/var_within_closure.cmo \
middle_end/base_types/static_exception.cmo \
middle_end/base_types/export_id.cmo \
COMPLIBDIR=$(LIBDIR)/compiler-libs
-INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-INSTALL_COMPLIBDIR=$(DESTDIR)$(COMPLIBDIR)
-INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
-INSTALL_MANDIR=$(DESTDIR)$(MANDIR)
-INSTALL_FLEXDLL=$(INSTALL_LIBDIR)/flexdll
-
+TOPINCLUDES=$(addprefix -I otherlibs/,$(filter-out %threads,$(OTHERLIBRARIES)))
RUNTOP=./byterun/ocamlrun ./ocaml \
-nostdlib -I stdlib \
- -noinit $(TOPFLAGS) \
- -I otherlibs/$(UNIXLIB)
-NATRUNTOP=./ocamlnat$(EXE) -nostdlib -I stdlib -noinit $(TOPFLAGS)
-ifeq "UNIX_OR_WIN32" "unix"
+ -noinit $(TOPFLAGS) $(TOPINCLUDES)
+NATRUNTOP=./ocamlnat$(EXE) \
+ -nostdlib -I stdlib \
+ -noinit $(TOPFLAGS) $(TOPINCLUDES)
+ifeq "$(UNIX_OR_WIN32)" "unix"
EXTRAPATH=
else
EXTRAPATH = PATH="otherlibs/win32unix:$(PATH)"
$(call SUBST,EXT_LIB) \
$(call SUBST,EXT_OBJ) \
$(call SUBST,FLAMBDA) \
+ $(call SUBST,WITH_FLAMBDA_INVARIANTS) \
$(call SUBST,FLEXLINK_FLAGS) \
$(call SUBST_QUOTE,FLEXDLL_DIR) \
$(call SUBST,HOST) \
# Build the core system: the minimum needed to make depend and bootstrap
.PHONY: core
core:
-ifeq "$(UNIX_OR_WIN32)" "unix"
$(MAKE) coldstart
-else # Windows, to be fixed!
- $(MAKE) runtime
-endif
$(MAKE) coreall
# Save the current bootstrap compiler
mkdir boot/Saved
mv boot/Saved.prev boot/Saved/Saved.prev
cp boot/ocamlrun$(EXE) boot/Saved
- cd boot; mv ocamlc ocamllex ocamlyacc$(EXE) ocamldep Saved
+ cd boot; mv ocamlc ocamllex ocamlyacc$(EXE) Saved
cd boot; cp $(LIBFILES) Saved
# Restore the saved bootstrap compiler if a problem arises
.PHONY: compare
compare:
@if $(CAMLRUN) tools/cmpbyt boot/ocamlc ocamlc \
- && $(CAMLRUN) tools/cmpbyt boot/ocamllex lex/ocamllex \
- && $(CAMLRUN) tools/cmpbyt boot/ocamldep tools/ocamldep; \
+ && $(CAMLRUN) tools/cmpbyt boot/ocamllex lex/ocamllex; \
then echo "Fixpoint reached, bootstrap succeeded."; \
else echo "Fixpoint not reached, try one more bootstrapping cycle."; \
fi
$(CAMLRUN) tools/stripdebug ocamlc boot/ocamlc
$(CAMLRUN) tools/stripdebug lex/ocamllex boot/ocamllex
cp yacc/ocamlyacc$(EXE) boot/ocamlyacc$(EXE)
- $(CAMLRUN) tools/stripdebug tools/ocamldep boot/ocamldep
cd stdlib; cp $(LIBFILES) ../boot
# Promote the newly compiled system to the rank of bootstrap compiler
.PHONY: opt
opt:
-ifeq "$(UNIX_OR_WIN32)" "unix"
$(MAKE) runtimeopt
$(MAKE) ocamlopt
$(MAKE) libraryopt
$(MAKE) otherlibrariesopt ocamltoolsopt
-else
- $(MAKE) opt-core
- $(MAKE) otherlibrariesopt ocamltoolsopt
-endif
# Native-code versions of the tools
.PHONY: opt.opt
-ifeq "$(UNIX_OR_WIN32)" "unix"
opt.opt:
$(MAKE) checkstack
$(MAKE) runtime
$(MAKE) otherlibrariesopt
$(MAKE) ocamllex.opt ocamltoolsopt ocamltoolsopt.opt $(OCAMLDOC_OPT) \
ocamltest.opt
-else
-opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \
- ocamltoolsopt ocamltoolsopt.opt otherlibrariesopt $(OCAMLDOC_OPT) \
- ocamltest.opt
-endif
-
-.PHONY: base.opt
-base.opt:
- $(MAKE) checkstack
- $(MAKE) runtime
- $(MAKE) core
- $(MAKE) ocaml
- $(MAKE) opt-core
- $(MAKE) ocamlc.opt
- $(MAKE) otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC) ocamltest
- $(MAKE) ocamlopt.opt
- $(MAKE) otherlibrariesopt
# Core bootstrapping cycle
.PHONY: coreboot
mv flexlink.exe flexlink.opt && \
mv flexlink flexlink.exe
+INSTALL_COMPLIBDIR=$(DESTDIR)$(COMPLIBDIR)
+INSTALL_FLEXDLLDIR=$(INSTALL_LIBDIR)/flexdll
+
.PHONY: install-flexdll
install-flexdll:
cat stdlib/camlheader flexdll/flexlink.exe > \
"$(INSTALL_BINDIR)/flexlink.exe"
ifneq "$(filter-out mingw,$(TOOLCHAIN))" ""
- cp flexdll/default$(filter-out _i386,_$(ARCH)).manifest \
+ $(INSTALL_DATA) flexdll/default$(filter-out _i386,_$(ARCH)).manifest \
"$(INSTALL_BINDIR)/"
endif
if test -n "$(wildcard flexdll/flexdll_*.$(O))" ; then \
- $(MKDIR) "$(INSTALL_FLEXDLL)" ; \
- cp flexdll/flexdll_*.$(O) "$(INSTALL_FLEXDLL)" ; \
+ $(MKDIR) "$(INSTALL_FLEXDLLDIR)" ; \
+ $(INSTALL_DATA) flexdll/flexdll_*.$(O) "$(INSTALL_FLEXDLLDIR)" ; \
fi
# Installation
$(MKDIR) "$(INSTALL_LIBDIR)"
$(MKDIR) "$(INSTALL_STUBLIBDIR)"
$(MKDIR) "$(INSTALL_COMPLIBDIR)"
- cp VERSION "$(INSTALL_LIBDIR)"
+ $(INSTALL_DATA) \
+ VERSION \
+ "$(INSTALL_LIBDIR)"
$(MAKE) -C byterun install
- cp ocaml "$(INSTALL_BINDIR)/ocaml$(EXE)"
- cp ocamlc "$(INSTALL_BINDIR)/ocamlc.byte$(EXE)"
+ $(INSTALL_PROG) ocaml "$(INSTALL_BINDIR)/ocaml$(EXE)"
+ $(INSTALL_PROG) ocamlc "$(INSTALL_BINDIR)/ocamlc.byte$(EXE)"
$(MAKE) -C stdlib install
- cp lex/ocamllex "$(INSTALL_BINDIR)/ocamllex.byte$(EXE)"
- cp yacc/ocamlyacc$(EXE) "$(INSTALL_BINDIR)/ocamlyacc$(EXE)"
- cp utils/*.cmi utils/*.cmt utils/*.cmti utils/*.mli \
+ $(INSTALL_PROG) lex/ocamllex "$(INSTALL_BINDIR)/ocamllex.byte$(EXE)"
+ $(INSTALL_PROG) yacc/ocamlyacc$(EXE) "$(INSTALL_BINDIR)/ocamlyacc$(EXE)"
+ $(INSTALL_DATA) \
+ utils/*.cmi utils/*.cmt utils/*.cmti utils/*.mli \
parsing/*.cmi parsing/*.cmt parsing/*.cmti parsing/*.mli \
typing/*.cmi typing/*.cmt typing/*.cmti typing/*.mli \
bytecomp/*.cmi bytecomp/*.cmt bytecomp/*.cmti bytecomp/*.mli \
driver/*.cmi driver/*.cmt driver/*.cmti driver/*.mli \
toplevel/*.cmi toplevel/*.cmt toplevel/*.cmti toplevel/*.mli \
"$(INSTALL_COMPLIBDIR)"
- cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
+ $(INSTALL_DATA) \
+ compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \
"$(INSTALL_COMPLIBDIR)"
- cp expunge "$(INSTALL_LIBDIR)/expunge$(EXE)"
- cp toplevel/topdirs.cmi toplevel/topdirs.cmt toplevel/topdirs.cmti \
- toplevel/topdirs.mli "$(INSTALL_LIBDIR)"
+ $(INSTALL_PROG) expunge "$(INSTALL_LIBDIR)/expunge$(EXE)"
+ $(INSTALL_DATA) \
+ toplevel/topdirs.cmi \
+ toplevel/topdirs.cmt toplevel/topdirs.cmti \
+ toplevel/topdirs.mli \
+ "$(INSTALL_LIBDIR)"
$(MAKE) -C tools install
ifeq "$(UNIX_OR_WIN32)" "unix" # Install manual pages only on Unix
$(MKDIR) "$(INSTALL_MANDIR)/man$(PROGRAMS_MAN_SECTION)"
$(MAKE) install-flexdll; \
fi
endif
- cp config/Makefile "$(INSTALL_LIBDIR)/Makefile.config"
+ $(INSTALL_DATA) config/Makefile "$(INSTALL_LIBDIR)/Makefile.config"
if test -f ocamlopt; then $(MAKE) installopt; else \
cd "$(INSTALL_BINDIR)"; \
$(LN) ocamlc.byte$(EXE) ocamlc$(EXE); \
.PHONY: installopt
installopt:
$(MAKE) -C asmrun install
- cp ocamlopt "$(INSTALL_BINDIR)/ocamlopt.byte$(EXE)"
+ $(INSTALL_PROG) ocamlopt "$(INSTALL_BINDIR)/ocamlopt.byte$(EXE)"
$(MAKE) -C stdlib installopt
- cp middle_end/*.cmi middle_end/*.cmt middle_end/*.cmti \
+ $(INSTALL_DATA) \
+ middle_end/*.cmi \
+ middle_end/*.cmt middle_end/*.cmti \
middle_end/*.mli \
- "$(INSTALL_COMPLIBDIR)"
- cp middle_end/base_types/*.cmi middle_end/base_types/*.cmt \
- middle_end/base_types/*.cmti middle_end/base_types/*.mli \
- "$(INSTALL_COMPLIBDIR)"
- cp asmcomp/*.cmi asmcomp/*.cmt asmcomp/*.cmti asmcomp/*.mli \
- "$(INSTALL_COMPLIBDIR)"
- cp compilerlibs/ocamloptcomp.cma $(OPTSTART) "$(INSTALL_COMPLIBDIR)"
+ "$(INSTALL_COMPLIBDIR)"
+ $(INSTALL_DATA) \
+ middle_end/base_types/*.cmi \
+ middle_end/base_types/*.cmt middle_end/base_types/*.cmti \
+ middle_end/base_types/*.mli \
+ "$(INSTALL_COMPLIBDIR)"
+ $(INSTALL_DATA) \
+ asmcomp/*.cmi \
+ asmcomp/*.cmt asmcomp/*.cmti \
+ asmcomp/*.mli \
+ "$(INSTALL_COMPLIBDIR)"
+ $(INSTALL_DATA) \
+ compilerlibs/ocamloptcomp.cma $(OPTSTART) \
+ "$(INSTALL_COMPLIBDIR)"
if test -n "$(WITH_OCAMLDOC)"; then \
$(MAKE) -C ocamldoc installopt; \
fi
fi
$(MAKE) -C tools installopt
if test -f ocamlopt.opt -a -f flexdll/flexlink.opt ; then \
- cp -f flexdll/flexlink.opt "$(INSTALL_BINDIR)/flexlink$(EXE)" ; \
+ $(INSTALL_PROG) \
+ flexdll/flexlink.opt "$(INSTALL_BINDIR)/flexlink$(EXE)" ; \
fi
.PHONY: installoptopt
installoptopt:
- cp ocamlc.opt "$(INSTALL_BINDIR)/ocamlc.opt$(EXE)"
- cp ocamlopt.opt "$(INSTALL_BINDIR)/ocamlopt.opt$(EXE)"
- cp lex/ocamllex.opt "$(INSTALL_BINDIR)/ocamllex.opt$(EXE)"
+ $(INSTALL_PROG) ocamlc.opt "$(INSTALL_BINDIR)/ocamlc.opt$(EXE)"
+ $(INSTALL_PROG) ocamlopt.opt "$(INSTALL_BINDIR)/ocamlopt.opt$(EXE)"
+ $(INSTALL_PROG) \
+ lex/ocamllex.opt "$(INSTALL_BINDIR)/ocamllex.opt$(EXE)"
cd "$(INSTALL_BINDIR)"; \
$(LN) ocamlc.opt$(EXE) ocamlc$(EXE); \
$(LN) ocamlopt.opt$(EXE) ocamlopt$(EXE); \
$(LN) ocamllex.opt$(EXE) ocamllex$(EXE)
- cp utils/*.cmx parsing/*.cmx typing/*.cmx bytecomp/*.cmx \
- driver/*.cmx asmcomp/*.cmx "$(INSTALL_COMPLIBDIR)"
- cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \
+ $(INSTALL_DATA) \
+ utils/*.cmx parsing/*.cmx typing/*.cmx bytecomp/*.cmx \
+ driver/*.cmx asmcomp/*.cmx \
+ "$(INSTALL_COMPLIBDIR)"
+ $(INSTALL_DATA) \
+ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \
compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \
- compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \
+ compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \
$(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.$(O)) \
$(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.$(O)) \
"$(INSTALL_COMPLIBDIR)"
if test -f ocamlnat$(EXE) ; then \
- cp ocamlnat$(EXE) "$(INSTALL_BINDIR)/ocamlnat$(EXE)"; \
- cp toplevel/opttopdirs.cmi "$(INSTALL_LIBDIR)"; \
- cp compilerlibs/ocamlopttoplevel.cmxa \
+ $(INSTALL_PROG) \
+ ocamlnat$(EXE) "$(INSTALL_BINDIR)/ocamlnat$(EXE)"; \
+ $(INSTALL_DATA) \
+ toplevel/opttopdirs.cmi \
+ "$(INSTALL_LIBDIR)"; \
+ $(INSTALL_DATA) \
+ compilerlibs/ocamlopttoplevel.cmxa \
compilerlibs/ocamlopttoplevel.$(A) \
$(OPTTOPLEVELSTART:.cmo=.cmx) $(OPTTOPLEVELSTART:.cmo=.$(O)) \
"$(INSTALL_COMPLIBDIR)"; \
# Installation of the *.ml sources of compiler-libs
.PHONY: install-compiler-sources
install-compiler-sources:
- cp utils/*.ml parsing/*.ml typing/*.ml bytecomp/*.ml driver/*.ml \
+ $(INSTALL_DATA) \
+ utils/*.ml parsing/*.ml typing/*.ml bytecomp/*.ml driver/*.ml \
toplevel/*.ml middle_end/*.ml middle_end/base_types/*.ml \
- asmcomp/*.ml $(INSTALL_COMPLIBDIR)
+ asmcomp/*.ml \
+ "$(INSTALL_COMPLIBDIR)"
# Run all tests
.PHONY: runtop
runtop:
-ifeq "$(UNIX_OR_WIN32)" "unix"
- $(MAKE) runtime
- $(MAKE) coreall
- $(MAKE) ocaml
-else
- $(MAKE) core
+ $(MAKE) coldstart
+ $(MAKE) ocamlc
+ $(MAKE) otherlibraries
$(MAKE) ocaml
-endif
@rlwrap --help 2>/dev/null && $(EXTRAPATH) rlwrap $(RUNTOP) ||\
$(EXTRAPATH) $(RUNTOP)
.PHONY: natruntop
natruntop:
- $(MAKE) runtime
- $(MAKE) coreall
- $(MAKE) opt.opt
+ $(MAKE) core
+ $(MAKE) opt
$(MAKE) ocamlnat
@rlwrap --help 2>/dev/null && $(EXTRAPATH) rlwrap $(NATRUNTOP) ||\
$(EXTRAPATH) $(NATRUNTOP)
otherlibs_all := bigarray dynlink graph raw_spacetime_lib \
str systhreads threads unix win32graph win32unix
subdirs := asmrun byterun debugger lex ocamldoc ocamltest stdlib tools \
- $(addprefix otherlibs/, $(otherlibs_all))
+ $(addprefix otherlibs/, $(otherlibs_all)) \
+ ocamldoc/stdlib_non_prefixed
.PHONY: alldepend
ifeq "$(TOOLCHAIN)" "msvc"
partialclean::
$(MAKE) -C debugger clean
-# Check that the stack limit is reasonable.
-ifeq "$(UNIX_OR_WIN32)" "unix"
+# Check that the stack limit is reasonable (Unix-only)
.PHONY: checkstack
checkstack:
+ifeq "$(UNIX_OR_WIN32)" "unix"
if $(MKEXE) $(OUTPUTEXE)tools/checkstack$(EXE) tools/checkstack.c; \
then tools/checkstack$(EXE); \
- else :; \
fi
rm -f tools/checkstack$(EXE)
+else
+ @
endif
# Lint @since and @deprecated annotations
clean::
cd testsuite; $(MAKE) clean
-# Make MacOS X package
-ifeq "$(UNIX_OR_WIN32)" "unix"
-.PHONY: package-macosx
-package-macosx:
- sudo rm -rf package-macosx/root
- $(MAKE) PREFIX="`pwd`"/package-macosx/root install
- tools/make-package-macosx
- sudo rm -rf package-macosx/root
-
-clean::
- rm -rf package-macosx/*.pkg package-macosx/*.dmg
-endif
-
# The middle end (whose .cma library is currently only used for linking
# the "ocamlobjinfo" program, since we cannot depend on the whole native code
# compiler for "make world" and the list of dependencies for
.PHONY: check_all_arches
check_all_arches:
+ifneq ($(shell grep -E '^\#define ARCH_SIXTYFOUR$$' byterun/caml/m.h 2> /dev/null),)
@STATUS=0; \
for i in $(ARCHES); do \
$(MAKE) --no-print-directory check_arch ARCH=$$i || STATUS=1; \
done; \
exit $$STATUS
+else
+ @echo "Architecture tests are disabled on 32-bit platforms."
+endif
# Compiler Plugins
rm -f config/Makefile byterun/caml/m.h byterun/caml/s.h
rm -f tools/*.bak
rm -f ocaml ocamlc
- rm -f testsuite/_log
+ rm -f testsuite/_log*
include .depend
--- /dev/null
+#**************************************************************************
+#* *
+#* OCaml *
+#* *
+#* Gabriel Scherer, projet Parsifal, INRIA Saclay *
+#* *
+#* Copyright 2018 Institut National de Recherche en Informatique et *
+#* en Automatique. *
+#* *
+#* All rights reserved. This file is distributed under the terms of *
+#* the GNU Lesser General Public License version 2.1, with the *
+#* special exception on linking described in the file LICENSE. *
+#* *
+#**************************************************************************
+
+# This makefile contains common definitions shared by other Makefiles
+# We assume that config/Makefile has already been included
+
+INSTALL ?= install
+INSTALL_DATA ?= $(INSTALL) -m u=rw,g=rw,o=r
+INSTALL_PROG ?= $(INSTALL) -m u=rwx,g=rwx,o=rx
+
+# note: these are defined by lazy expansions
+# as some parts of the makefiles change BINDIR, etc.
+# and expect INSTALL_BINDIR, etc. to stay in synch
+# (see `shellquote` in tools/Makefile)
+INSTALL_BINDIR = $(DESTDIR)$(BINDIR)
+INSTALL_LIBDIR = $(DESTDIR)$(LIBDIR)
+INSTALL_STUBLIBDIR = $(DESTDIR)$(STUBLIBDIR)
+INSTALL_MANDIR = $(DESTDIR)$(MANDIR)
|=====
-| Branch `trunk` | Branch `4.05` | Branch `4.04`
+| Branch `trunk` | Branch `4.06` | Branch `4.05` | Branch `4.04`
| image:https://travis-ci.org/ocaml/ocaml.svg?branch=trunk["TravisCI Build Status (trunk branch)",link="https://travis-ci.org/ocaml/ocaml"]
image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=trunk&svg=true["AppVeyor Build Status (trunk branch)",link="https://ci.appveyor.com/project/avsm/ocaml"]
+| image:https://travis-ci.org/ocaml/ocaml.svg?branch=4.06["TravisCI Build Status (4.06 branch)",link="https://travis-ci.org/ocaml/ocaml"]
+ image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=4.06&svg=true["AppVeyor Build Status (4.06 branch)",link="https://ci.appveyor.com/project/avsm/ocaml"]
| image:https://travis-ci.org/ocaml/ocaml.svg?branch=4.05["TravisCI Build Status (4.05 branch)",link="https://travis-ci.org/ocaml/ocaml"]
image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=4.05&svg=true["AppVeyor Build Status (4.05 branch)",link="https://ci.appveyor.com/project/avsm/ocaml"]
| image:https://travis-ci.org/ocaml/ocaml.svg?branch=4.04["TravisCI Build Status (4.04 branch)",link="https://travis-ci.org/ocaml/ocaml"]
The OCaml manual is distributed in HTML, PDF, Postscript, DVI, and Emacs
Info files. It is available at
-http://caml.inria.fr/
-
-The community also maintains the Web site http://ocaml.org, with tutorials
-and other useful information for OCaml users.
+http://caml.inria.fr/pub/docs/manual-ocaml/
== Availability
The complete OCaml distribution can be accessed at
-http://caml.inria.fr/
+http://ocaml.org/docs/install.html
== Keeping in Touch with the Caml Community
-There exists a mailing list of users of the OCaml implementations developed
-at INRIA. The purpose of this list is to share experience, exchange ideas
-(and even code), and report on applications of the OCaml language. Messages
-can be written in English or in French. The list has more than 1000
-subscribers.
-
-Messages to the list should be sent to:
+The OCaml mailing list is the longest-running forum for OCaml users.
+You can email it at
mailto:caml-list@inria.fr[]
-You can subscribe to this list via the Web interface at
+You can subscribe and access list archives via the Web interface at
https://sympa.inria.fr/sympa/subscribe/caml-list
-Archives of the list are available on the Web site above.
+You can also access a newer discussion forum at
-The Usenet news `groups comp.lang.ml` and `comp.lang.functional` also
-contains discussions about the ML family of programming languages, including
-OCaml.
+https://discuss.ocaml.org/
-The IRC channel `#ocaml` on https://freenode.net/[Freenode] also has several
-hundred users and welcomes questions.
+There also exist other mailing lists, chat channels, and various other forums
+around the internet for getting in touch with the OCaml and ML family language
+community. These can be accessed at
-The OCaml Community website is
+http://ocaml.org/community/
-http://ocaml.org/
+In particular, the IRC channel `#ocaml` on https://freenode.net/[Freenode] has a
+long history and welcomes questions.
== Bug Reports and User Feedback
eval $(tools/msvs-promote-path)
-If you forget to do this, `make world` will fail relatively
+If you forget to do this, `make world.opt` will fail relatively
quickly as it will be unable to link `ocamlrun`.
Now run:
Finally, use `make` to build the system, e.g.
- make world bootstrap opt opt.opt install
+ make world.opt
+ make install
After installing, it is not necessary to keep the Cygwin installation (although
you may require it to build additional third party libraries and tools). You
Finally, use `make` to build the system, e.g.
- make world bootstrap opt opt.opt install
+ make world.opt
+ make install
After installing, you will need to ensure that `ocamlopt` (or `ocamlc -custom`)
can access the C compiler. You can do this either by using OCaml from Cygwin's
* The replay debugger is partially supported (no reverse execution).
-* The default `config/Makefile.mingw` and `config/Makefile.mingw64` pass
- `-static-libgcc` to the linker. For more information on this topic:
-
- - http://gcc.gnu.org/onlinedocs/gcc-4.9.1/gcc/Link-Options.html#Link-Options
- - http://caml.inria.fr/mantis/view.php?id=6411
-
[[seflexdll]]
== FlexDLL
Although the core of FlexDLL is necessarily written in C, the `flexlink` program
OCaml is then compiled as normal for the port you require, except that before
compiling `world`, you must compile `flexdll`, i.e.:
- make flexdll world [bootstrap] opt opt.opt flexlink.opt install
+ make flexdll
+ make world.opt
+ make flexlink.opt
+ make install
* You should ignore the error messages that say ocamlopt was not found.
* `make install` will install FlexDLL by placing `flexlink.exe`
-4.06.1
+4.07.0
# The version string is the first line of this file.
# It must be in the format described in stdlib/sys.mli
install:
# This is a hangover from monitoring effects of MPR#7452
- wmic cpu get name
- - call "%APPVEYOR_BUILD_FOLDER%\appveyor_build.cmd" install
+ - call "%APPVEYOR_BUILD_FOLDER%\tools\ci\appveyor\appveyor_build.cmd" install
build_script:
- - call "%APPVEYOR_BUILD_FOLDER%\appveyor_build.cmd" build
+ - call "%APPVEYOR_BUILD_FOLDER%\tools\ci\appveyor\appveyor_build.cmd" build
test_script:
- - call "%APPVEYOR_BUILD_FOLDER%\appveyor_build.cmd" test
+ - call "%APPVEYOR_BUILD_FOLDER%\tools\ci\appveyor\appveyor_build.cmd" test
+++ /dev/null
-@rem ***********************************************************************
-@rem * *
-@rem * OCaml *
-@rem * *
-@rem * David Allsopp, OCaml Labs, Cambridge. *
-@rem * *
-@rem * Copyright 2017 MetaStack Solutions Ltd. *
-@rem * *
-@rem * All rights reserved. This file is distributed under the terms of *
-@rem * the GNU Lesser General Public License version 2.1, with the *
-@rem * special exception on linking described in the file LICENSE. *
-@rem * *
-@rem ***********************************************************************
-
-@rem BE CAREFUL ALTERING THIS FILE TO ENSURE THAT ERRORS PROPAGATE
-@rem IF A COMMAND SHOULD FAIL IT PROBABLY NEEDS TO END WITH
-@rem || exit /b 1
-@rem BASICALLY, DO THE TESTING IN BASH...
-
-@rem Do not call setlocal!
-@echo off
-
-goto %1
-
-goto :EOF
-
-:SaveVars
-set OCAML_PREV_PATH=%PATH%
-set OCAML_PREV_LIB=%LIB%
-set OCAML_PREV_INCLUDE=%INCLUDE%
-goto :EOF
-
-:RestoreVars
-set PATH=%OCAML_PREV_PATH%
-set LIB=%OCAML_PREV_LIB%
-set INCLUDE=%OCAML_PREV_INCLUDE%
-goto :EOF
-
-:CheckPackage
-"%CYG_ROOT%\bin\bash.exe" -lc "cygcheck -dc %1" | findstr %1 > nul
-if %ERRORLEVEL% equ 1 (
- echo Cygwin package %1 will be installed
- set CYGWIN_INSTALL_PACKAGES=%CYGWIN_INSTALL_PACKAGES%,%1
-)
-goto :EOF
-
-:UpgradeCygwin
-if "%CYGWIN_INSTALL_PACKAGES%" neq "" "%CYG_ROOT%\setup-x86_64.exe" --quiet-mode --no-shortcuts --no-startmenu --no-desktop --only-site --root "%CYG_ROOT%" --site "%CYG_MIRROR%" --local-package-dir "%CYG_CACHE%" --packages %CYGWIN_INSTALL_PACKAGES:~1% > nul
-for %%P in (%CYGWIN_COMMANDS%) do "%CYG_ROOT%\bin\%%P.exe" --version > nul || set CYGWIN_UPGRADE_REQUIRED=1
-"%CYG_ROOT%\bin\bash.exe" -lc "cygcheck -dc %CYGWIN_PACKAGES%"
-if %CYGWIN_UPGRADE_REQUIRED% equ 1 (
- echo Cygwin package upgrade required - please go and drink coffee
- "%CYG_ROOT%\setup-x86_64.exe" --quiet-mode --no-shortcuts --no-startmenu --no-desktop --only-site --root "%CYG_ROOT%" --site "%CYG_MIRROR%" --local-package-dir "%CYG_CACHE%" --upgrade-also > nul
- "%CYG_ROOT%\bin\bash.exe" -lc "cygcheck -dc %CYGWIN_PACKAGES%"
-)
-goto :EOF
-
-:install
-chcp 65001 > nul
-rem This must be kept in sync with appveyor_build.sh
-set BUILD_PREFIX=🐫реализация
-git worktree add "..\%BUILD_PREFIX%-msvc64" -b appveyor-build-msvc64
-git worktree add "..\%BUILD_PREFIX%-mingw32" -b appveyor-build-mingw32
-git worktree add "..\%BUILD_PREFIX%-msvc32" -b appveyor-build-msvc32
-cd "..\%BUILD_PREFIX%-mingw32"
-git submodule update --init flexdll
-
-cd "%APPVEYOR_BUILD_FOLDER%"
-appveyor DownloadFile "https://github.com/alainfrisch/flexdll/archive/0.37.tar.gz" -FileName "flexdll.tar.gz" || exit /b 1
-appveyor DownloadFile "https://github.com/alainfrisch/flexdll/releases/download/0.37/flexdll-bin-0.37.zip" -FileName "flexdll.zip" || exit /b 1
-rem flexdll.zip is processed here, rather than in appveyor_build.sh because the
-rem unzip command comes from MSYS2 (via Git for Windows) and it has to be
-rem invoked via cmd /c in a bash script which is weird(er).
-mkdir "%APPVEYOR_BUILD_FOLDER%\..\flexdll"
-move flexdll.zip "%APPVEYOR_BUILD_FOLDER%\..\flexdll"
-cd "%APPVEYOR_BUILD_FOLDER%\..\flexdll" && unzip -q flexdll.zip
-
-rem CYGWIN_PACKAGES is the list of required Cygwin packages (cygwin is included
-rem in the list just so that the Cygwin version is always displayed on the log).
-rem CYGWIN_COMMANDS is a corresponding command to run with --version to test
-rem whether the package works. This is used to verify whether the installation
-rem needs upgrading.
-set CYGWIN_PACKAGES=cygwin make diffutils mingw64-i686-gcc-core
-set CYGWIN_COMMANDS=cygcheck make diff i686-w64-mingw32-gcc
-
-set CYGWIN_INSTALL_PACKAGES=
-set CYGWIN_UPGRADE_REQUIRED=0
-
-for %%P in (%CYGWIN_PACKAGES%) do call :CheckPackage %%P
-call :UpgradeCygwin
-
-"%CYG_ROOT%\bin\bash.exe" -lec "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh install" || exit /b 1
-
-call :SaveVars
-goto :EOF
-
-:build
-rem Run the msvc64 and mingw32 builds
-call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat"
-"%CYG_ROOT%\bin\bash.exe" -lec "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh" || exit /b 1
-
-rem Reconfigure the environment and run the msvc32 partial build
-call :RestoreVars
-call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x86
-"%CYG_ROOT%\bin\bash.exe" -lec "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh msvc32-only" || exit /b 1
-goto :EOF
-
-:test
-rem Reconfigure the environment for the msvc64 build
-call :RestoreVars
-call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat"
-"%CYG_ROOT%\bin\bash.exe" -lec "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh test" || exit /b 1
-goto :EOF
+++ /dev/null
-#!/bin/bash
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Christophe Troestler *
-#* *
-#* Copyright 2015 Christophe Troestler *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BUILD_PID=0
-
-function run {
- NAME=$1
- shift
- echo "-=-=- $NAME -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-"
- $@
- CODE=$?
- if [ $CODE -ne 0 ]; then
- echo "-=-=- $NAME failed! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-"
- if [ $BUILD_PID -ne 0 ] ; then
- kill -KILL $BUILD_PID 2>/dev/null
- wait $BUILD_PID 2>/dev/null
- fi
- exit $CODE
- else
- echo "-=-=- End of $NAME -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-"
- fi
-}
-
-function set_configuration {
- cp config/m-nt.h byterun/caml/m.h
- cp config/s-nt.h byterun/caml/s.h
-
- FILE=$(pwd | cygpath -f - -m)/config/Makefile
- echo "Edit $FILE to set PREFIX=$2"
- sed -e "/PREFIX=/s|=.*|=$2|" \
- -e "/^ *CFLAGS *=/s/\r\?$/ $3\0/" \
- config/Makefile.$1 > config/Makefile
-# run "Content of $FILE" cat config/Makefile
-}
-
-APPVEYOR_BUILD_FOLDER=$(echo $APPVEYOR_BUILD_FOLDER| cygpath -f -)
-# These directory names are specified here, because getting UTF-8 correctly
-# through appveyor.yml -> Command Script -> Bash is quite painful...
-OCAMLROOT=$(echo $PROGRAMFILES/Бактріан🐫| cygpath -f - -m)
-
-# This must be kept in sync with appveyor_build.cmd
-BUILD_PREFIX=🐫реализация
-
-export PATH=$(echo $OCAMLROOT| cygpath -f -)/bin/flexdll:$PATH
-
-case "$1" in
- install)
- mkdir -p "$OCAMLROOT/bin/flexdll"
- cd $APPVEYOR_BUILD_FOLDER/../flexdll
- # msvc64 objects need to be compiled with VS2015, so are copied later from
- # a source build.
- for f in flexdll.h flexlink.exe flexdll*_msvc.obj default*.manifest ; do
- cp $f "$OCAMLROOT/bin/flexdll/"
- done
- echo 'eval $($APPVEYOR_BUILD_FOLDER/tools/msvs-promote-path)' >> ~/.bash_profile
- ;;
- msvc32-only)
- cd $APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX-msvc32
-
- set_configuration msvc "$OCAMLROOT-msvc32" -WX
-
- run "make world" make world
- run "make runtimeopt" make runtimeopt
- run "make -C otherlibs/systhreads libthreadsnat.lib" \
- make -C otherlibs/systhreads libthreadsnat.lib
-
- exit 0
- ;;
- test)
- FULL_BUILD_PREFIX=$APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX
- run "ocamlc.opt -version" $FULL_BUILD_PREFIX-msvc64/ocamlc.opt -version
- run "test msvc64" make -C $FULL_BUILD_PREFIX-msvc64 tests
- run "test mingw32" make -C $FULL_BUILD_PREFIX-mingw32 tests
- run "install msvc64" make -C $FULL_BUILD_PREFIX-msvc64 install
- run "install mingw32" make -C $FULL_BUILD_PREFIX-mingw32 install
- ;;
- *)
- cd $APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX-msvc64
-
- tar -xzf $APPVEYOR_BUILD_FOLDER/flexdll.tar.gz
- cd flexdll-$FLEXDLL_VERSION
- make MSVC_DETECT=0 CHAINS=msvc64 support
- cp flexdll*_msvc64.obj "$OCAMLROOT/bin/flexdll/"
- cd ..
-
- set_configuration msvc64 "$OCAMLROOT" -WX
-
- cd ../$BUILD_PREFIX-mingw32
-
- set_configuration mingw "$OCAMLROOT-mingw32" -Werror
-
- cd $APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX-msvc64
-
- export TERM=ansi
- script --quiet --return --command "make -C ../$BUILD_PREFIX-mingw32 flexdll world.opt" ../$BUILD_PREFIX-mingw32/build.log >/dev/null 2>/dev/null &
- BUILD_PID=$!
-
- run "make world" make world
- run "make bootstrap" make bootstrap
- run "make opt" make opt
- run "make opt.opt" make opt.opt
-
- set +e
-
- # For an explanation of the sed command, see https://github.com/appveyor/ci/issues/1824
- tail --pid=$BUILD_PID -n +1 -f ../$BUILD_PREFIX-mingw32/build.log | sed -e 's/\d027\[K//g' -e 's/\d027\[m/\d027[0m/g' -e 's/\d027\[01\([m;]\)/\d027[1\1/g' &
- TAIL_PID=$!
- wait $BUILD_PID
- STATUS=$?
- wait $TAIL_PID
- exit $STATUS
- ;;
-esac
next = self#cse empty_numbering i.next}
method fundecl f =
- {f with fun_body = self#cse empty_numbering f.fun_body}
+ (* CSE can trigger bad register allocation behaviors, see MPR#7630 *)
+ if List.mem Cmm.No_CSE f.fun_codegen_options then
+ f
+ else
+ {f with fun_body = self#cse empty_numbering f.fun_body }
end
(* Output a floating-point compare and branch *)
-let emit_float_test cmp neg i lbl =
+let emit_float_test cmp i lbl =
(* Effect of comisd on flags and conditional branches:
ZF PF CF cond. branches taken
unordered 1 1 1 je, jb, jbe, jp
If FP traps are on (they are off by default),
comisd traps on QNaN and SNaN but ucomisd traps on SNaN only.
*)
- match (cmp, neg) with
- | (Ceq, false) | (Cne, true) ->
+ match cmp with
+ | CFeq ->
let next = new_label() in
I.ucomisd (arg i 1) (arg i 0);
I.jp (label next); (* skip if unordered *)
I.je lbl; (* branch taken if x=y *)
def_label next
- | (Cne, false) | (Ceq, true) ->
+ | CFneq ->
I.ucomisd (arg i 1) (arg i 0);
I.jp lbl; (* branch taken if unordered *)
I.jne lbl (* branch taken if x<y or x>y *)
- | (Clt, _) ->
+ | CFlt ->
I.comisd (arg i 0) (arg i 1);
- if not neg then I.ja lbl (* branch taken if y>x i.e. x<y *)
- else I.jbe lbl (* taken if unordered or y<=x i.e. !(x<y) *)
- | (Cle, _) ->
+ I.ja lbl (* branch taken if y>x i.e. x<y *)
+ | CFnlt ->
+ I.comisd (arg i 0) (arg i 1);
+ I.jbe lbl (* taken if unordered or y<=x i.e. !(x<y) *)
+ | CFle ->
+ I.comisd (arg i 0) (arg i 1);(* swap compare *)
+ I.jae lbl (* branch taken if y>=x i.e. x<=y *)
+ | CFnle ->
I.comisd (arg i 0) (arg i 1);(* swap compare *)
- if not neg then I.jae lbl (* branch taken if y>=x i.e. x<=y *)
- else I.jb lbl (* taken if unordered or y<x i.e. !(x<=y) *)
- | (Cgt, _) ->
+ I.jb lbl (* taken if unordered or y<x i.e. !(x<=y) *)
+ | CFgt ->
I.comisd (arg i 1) (arg i 0);
- if not neg then I.ja lbl (* branch taken if x>y *)
- else I.jbe lbl (* taken if unordered or x<=y i.e. !(x>y) *)
- | (Cge, _) ->
+ I.ja lbl (* branch taken if x>y *)
+ | CFngt ->
+ I.comisd (arg i 1) (arg i 0);
+ I.jbe lbl (* taken if unordered or x<=y i.e. !(x>y) *)
+ | CFge ->
+ I.comisd (arg i 1) (arg i 0);(* swap compare *)
+ I.jae lbl (* branch taken if x>=y *)
+ | CFnge ->
I.comisd (arg i 1) (arg i 0);(* swap compare *)
- if not neg then I.jae lbl (* branch taken if x>=y *)
- else I.jb lbl (* taken if unordered or x<y i.e. !(x>=y) *)
+ I.jb lbl (* taken if unordered or x<y i.e. !(x>=y) *)
(* Deallocate the stack frame before a return or tail call *)
| Iinttest_imm(cmp, n) ->
I.cmp (int n) (arg i 0);
I.j (cond cmp) lbl
- | Ifloattest(cmp, neg) ->
- emit_float_test cmp neg i lbl
+ | Ifloattest cmp ->
+ emit_float_test cmp i lbl
| Ioddtest ->
I.test (int 1) (arg8 i 0);
I.jne lbl
if stackp arg.(0) && stackp arg.(1)
then [| self#makereg arg.(0); arg.(1) |]
else arg
- | Ifloattest((Clt|Cle), _) ->
+ | Ifloattest (CFlt | CFnlt | CFle | CFnle) ->
(* Cf. emit.mlp: we swap arguments in this case *)
(* First argument can be on stack, second must be in register *)
if stackp arg.(1)
then [| arg.(0); self#makereg arg.(1) |]
else arg
- | Ifloattest((Ceq|Cne|Cgt|Cge), _) ->
+ | Ifloattest (CFeq | CFneq | CFgt | CFngt | CFge | CFnge) ->
(* Second argument can be on stack, first must be in register *)
if stackp arg.(0)
then [| self#makereg arg.(0); arg.(1) |]
open Format
type abi = EABI | EABI_HF
-type arch = ARMv4 | ARMv5 | ARMv5TE | ARMv6 | ARMv6T2 | ARMv7
+type arch = ARMv4 | ARMv5 | ARMv5TE | ARMv6 | ARMv6T2 | ARMv7 | ARMv8
type fpu = Soft | VFPv2 | VFPv3_D16 | VFPv3
let abi =
| ARMv6 -> "armv6"
| ARMv6T2 -> "armv6t2"
| ARMv7 -> "armv7"
+ | ARMv8 -> "armv8"
let string_of_fpu = function
Soft -> "soft"
| EABI, "armv6" -> ARMv6, Soft, false
| EABI, "armv6t2" -> ARMv6T2, Soft, false
| EABI, "armv7" -> ARMv7, Soft, false
+ | EABI, "armv8" -> ARMv8, Soft, false
| EABI, _ -> ARMv4, Soft, false
| EABI_HF, "armv6" -> ARMv6, VFPv2, false
+ | EABI_HF, "armv8" -> ARMv8, VFPv3, true
| EABI_HF, _ -> ARMv7, VFPv3_D16, true
end in
(ref def_arch, ref def_fpu, ref def_thumb)
| "armv6" -> ARMv6
| "armv6t2" -> ARMv6T2
| "armv7" -> ARMv7
+ | "armv8" -> ARMv8
| spec -> raise (Arg.Bad ("wrong '-farch' option: " ^ spec))
end
(* Negate a comparison *)
let negate_integer_comparison = function
- Isigned cmp -> Isigned(negate_comparison cmp)
- | Iunsigned cmp -> Iunsigned(negate_comparison cmp)
+ | Isigned cmp -> Isigned(negate_integer_comparison cmp)
+ | Iunsigned cmp -> Iunsigned(negate_integer_comparison cmp)
(* Names of various instructions *)
1
end
+(* Emit instructions that set [rd] to 1 if integer condition [cmp] holds
+ and set [rd] to 0 otherwise. *)
+
+let emit_set_condition cmp rd =
+ let compthen = name_for_comparison cmp in
+ let compelse = name_for_comparison (negate_integer_comparison cmp) in
+ if !arch < ARMv8 || not !thumb then begin
+ ` ite {emit_string compthen}\n`;
+ ` mov{emit_string compthen} {emit_reg rd}, #1\n`;
+ ` mov{emit_string compelse} {emit_reg rd}, #0\n`;
+ 3
+ end else begin
+ (* T32 mode in ARMv8 deprecates general ITE blocks
+ and favors IT blocks containing only one 16-bit instruction.
+ mov <reg>, #<imm> is 16 bits if <reg> is R0...R7
+ and <imm> fits in 8 bits. *)
+ let temp =
+ match rd.loc with
+ | Reg r when r < 8 -> rd (* can assign rd directly *)
+ | _ -> phys_reg 3 (* use r3 as temporary *) in
+ ` it {emit_string compthen}\n`;
+ ` mov{emit_string compthen} {emit_reg temp}, #1\n`;
+ ` it {emit_string compelse}\n`;
+ ` mov{emit_string compelse} {emit_reg temp}, #0\n`;
+ if temp.loc = rd.loc then 4 else begin
+ ` movs {emit_reg rd}, {emit_reg temp}\n`; 5
+ end
+ end
+
(* Output the assembly code for an instruction *)
let emit_instr i =
1 + ninstr
end
| Lop(Iintop(Icomp cmp)) ->
- let compthen = name_for_comparison cmp in
- let compelse = name_for_comparison (negate_integer_comparison cmp) in
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
- ` ite {emit_string compthen}\n`;
- ` mov{emit_string compthen} {emit_reg i.res.(0)}, #1\n`;
- ` mov{emit_string compelse} {emit_reg i.res.(0)}, #0\n`; 4
+ 1 + emit_set_condition cmp i.res.(0)
| Lop(Iintop_imm(Icomp cmp, n)) ->
- let compthen = name_for_comparison cmp in
- let compelse = name_for_comparison (negate_integer_comparison cmp) in
` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
- ` ite {emit_string compthen}\n`;
- ` mov{emit_string compthen} {emit_reg i.res.(0)}, #1\n`;
- ` mov{emit_string compelse} {emit_reg i.res.(0)}, #0\n`; 4
+ 1 + emit_set_condition cmp i.res.(0)
| Lop(Iintop (Icheckbound { label_after_error; } )) ->
let lbl = bound_error_label ?label:label_after_error i.dbg in
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
let comp = name_for_comparison cmp in
` b{emit_string comp} {emit_label lbl}\n`; 2
- | Ifloattest(cmp, neg) ->
- let comp = (match (cmp, neg) with
- (Ceq, false) | (Cne, true) -> "eq"
- | (Cne, false) | (Ceq, true) -> "ne"
- | (Clt, false) -> "cc"
- | (Clt, true) -> "cs"
- | (Cle, false) -> "ls"
- | (Cle, true) -> "hi"
- | (Cgt, false) -> "gt"
- | (Cgt, true) -> "le"
- | (Cge, false) -> "ge"
- | (Cge, true) -> "lt") in
+ | Ifloattest cmp ->
+ let comp =
+ match cmp with
+ | CFeq -> "eq"
+ | CFneq -> "ne"
+ | CFlt -> "cc"
+ | CFnlt -> "cs"
+ | CFle -> "ls"
+ | CFnle -> "hi"
+ | CFgt -> "gt"
+ | CFngt -> "le"
+ | CFge -> "ge"
+ | CFnge -> "lt"
+ in
` fcmpd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
` fmstat\n`;
` b{emit_string comp} {emit_label lbl}\n`; 3
| ARMv6 -> ` .arch armv6\n`
| ARMv6T2 -> ` .arch armv6t2\n`
| ARMv7 -> ` .arch armv7-a\n`
+ | ARMv8 -> ` .arch armv8-a\n`
end;
begin match !fpu with
Soft -> ` .fpu softvfp\n`
[| phys_reg 3; phys_reg 8 |] (* r3 and r12 destroyed *)
| Iop(Iintop Imulh) when !arch < ARMv6 ->
[| phys_reg 8 |] (* r12 destroyed *)
+ | Iop(Iintop (Icomp _) | Iintop_imm(Icomp _, _))
+ when !arch >= ARMv8 && !thumb ->
+ [| phys_reg 3 |] (* r3 destroyed *)
| Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _)) ->
[| phys_reg 107 |] (* d7 (s14-s15) destroyed *)
| _ -> [||]
let is_offset chunk n =
match chunk with
- (* VFPv{2,3} load/store have -1020 to 1020 *)
- Single | Double | Double_u
+ (* VFPv{2,3} load/store have -1020 to 1020. Offset must be multiple of 4 *)
+ | Single | Double | Double_u
when !fpu >= VFPv2 ->
- n >= -1020 && n <= 1020
+ n >= -1020 && n <= 1020 && n mod 4 = 0
(* ARM load/store byte/word have -4095 to 4095 *)
| Byte_unsigned | Byte_signed
| Thirtytwo_unsigned | Thirtytwo_signed
| (Cfloatofint, args) -> (self#iextcall("__aeabi_i2d", false), args)
| (Cintoffloat, args) -> (self#iextcall("__aeabi_d2iz", false), args)
| (Ccmpf comp, args) ->
- let func = (match comp with
- Cne (* there's no __aeabi_dcmpne *)
- | Ceq -> "__aeabi_dcmpeq"
- | Clt -> "__aeabi_dcmplt"
- | Cle -> "__aeabi_dcmple"
- | Cgt -> "__aeabi_dcmpgt"
- | Cge -> "__aeabi_dcmpge") in
- let comp = (match comp with
- Cne -> Ceq (* eq 0 => false *)
- | _ -> Cne (* ne 0 => true *)) in
+ let comp, func =
+ match comp with
+ | CFeq -> Cne, "__aeabi_dcmpeq"
+ | CFneq -> Ceq, "__aeabi_dcmpeq"
+ | CFlt -> Cne, "__aeabi_dcmplt"
+ | CFnlt -> Ceq, "__aeabi_dcmplt"
+ | CFle -> Cne, "__aeabi_dcmple"
+ | CFnle -> Ceq, "__aeabi_dcmple"
+ | CFgt -> Cne, "__aeabi_dcmpgt"
+ | CFngt -> Ceq, "__aeabi_dcmpgt"
+ | CFge -> Cne, "__aeabi_dcmpge"
+ | CFnge -> Ceq, "__aeabi_dcmpge"
+ in
(Iintop_imm(Icomp(Iunsigned comp), 0),
[Cop(Cextcall(func, typ_int, false, None), args, dbg)])
(* Add coercions around loads and stores of 32-bit floats *)
` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
let comp = name_for_comparison cmp in
` b.{emit_string comp} {emit_label lbl}\n`
- | Ifloattest(cmp, neg) ->
- let comp = (match (cmp, neg) with
- | (Ceq, false) | (Cne, true) -> "eq"
- | (Cne, false) | (Ceq, true) -> "ne"
- | (Clt, false) -> "cc"
- | (Clt, true) -> "cs"
- | (Cle, false) -> "ls"
- | (Cle, true) -> "hi"
- | (Cgt, false) -> "gt"
- | (Cgt, true) -> "le"
- | (Cge, false) -> "ge"
- | (Cge, true) -> "lt") in
+ | Ifloattest cmp ->
+ let comp =
+ match cmp with
+ | CFeq -> "eq"
+ | CFneq -> "ne"
+ | CFlt -> "cc"
+ | CFnlt -> "cs"
+ | CFle -> "ls"
+ | CFnle -> "hi"
+ | CFgt -> "gt"
+ | CFngt -> "le"
+ | CFge -> "ge"
+ | CFnge -> "lt"
+ in
` fcmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
` b.{emit_string comp} {emit_label lbl}\n`
| Ioddtest ->
let flambda_gen_implementation ?toplevel ~backend ppf
(program:Flambda.program) =
- let export = Build_export_info.build_export_info ~backend program in
+ let export = Build_export_info.build_transient ~backend program in
let (clambda, preallocated, constants) =
Profile.record_call "backend" (fun () ->
(program, export)
symbol = Compilenv.make_symbol None;
exported = true;
tag = 0;
- size = lambda.main_module_block_size;
+ fields = List.init lambda.main_module_block_size (fun _ -> None);
}
in
let clambda_and_constants =
try
find_in_path !load_path name
with Not_found ->
- fatal_error "Asmlink.object_file_name: not found" in
+ fatal_errorf "Asmlink.object_file_name: %s not found" name in
if Filename.check_suffix file_name ".cmx" then
Filename.chop_suffix file_name ".cmx" ^ ext_obj
else if Filename.check_suffix file_name ".cmxa" then
(* Second pass: generate the startup file and link it with everything else *)
+let force_linking_of_startup ppf =
+ Asmgen.compile_phrase ppf (Cmm.Cdata ([Cmm.Csymbol_address "caml_startup"]))
+
let make_startup_file ppf units_list =
let compile_phrase p = Asmgen.compile_phrase ppf p in
Location.input_name := "caml_startup"; (* set name of "current" input *)
if Config.spacetime then begin
compile_phrase (Cmmgen.spacetime_shapes all_names);
end;
+ if !Clflags.output_complete_object then
+ force_linking_of_startup ppf;
Emit.end_assembly ()
let make_shared_startup_file ppf units =
compile_phrase
(Cmmgen.global_table
(List.map (fun (ui,_) -> ui.ui_symbol) units));
+ if !Clflags.output_complete_object then
+ force_linking_of_startup ppf;
(* this is to force a reference to all units, otherwise the linker
might drop some of them (in case of libraries) *)
Emit.end_assembly ()
implementations_defined := [];
cmx_required := [];
interfaces := [];
- implementations := []
+ implementations := [];
+ lib_ccobjs := [];
+ lib_ccopts := []
type t
val new_descr : t -> Export_info.descr -> Export_id.t
+
val record_descr : t -> Export_id.t -> Export_info.descr -> unit
+ val new_value_closure_descr
+ : t
+ -> closure_id:Closure_id.t
+ -> set_of_closures: Export_info.value_set_of_closures
+ -> Export_id.t
+
val get_descr : t -> Export_info.approx -> Export_info.descr option
val add_approx : t -> Variable.t -> Export_info.approx -> t
(* Note that [ex_table]s themselves are shared (hence [ref] and not
[mutable]). *)
ex_table : Export_info.descr Export_id.Map.t ref;
+ closure_table : Export_id.t Closure_id.Map.t ref;
}
let create_empty () =
{ sym = Symbol.Map.empty;
ex_table = ref Export_id.Map.empty;
+ closure_table = ref Closure_id.Map.empty;
}
let add_symbol t sym export_id =
{ var : Export_info.approx Variable.Map.t;
sym : Export_id.t Symbol.Map.t;
ex_table : Export_info.descr Export_id.Map.t ref;
+ closure_table: Export_id.t Closure_id.Map.t ref;
}
let empty_of_global (env : Global.t) =
{ var = Variable.Map.empty;
sym = env.sym;
ex_table = env.ex_table;
+ closure_table = env.closure_table;
}
let extern_id_descr export_id =
if Compilenv.is_predefined_exception sym
then None
else
- let export = Compilenv.approx_for_global (Symbol.compilation_unit sym) in
- try
- let id = Symbol.Map.find sym export.symbol_id in
- let descr = Export_info.find_description export id in
- Some descr
+ match
+ Compilenv.approx_for_global (Symbol.compilation_unit sym)
with
- | Not_found -> None
+ | None -> None
+ | Some export ->
+ try
+ let id = Symbol.Map.find sym export.symbol_id in
+ let descr = Export_info.find_description export id in
+ Some descr
+ with
+ | Not_found -> None
let get_id_descr t export_id =
try Some (Export_id.Map.find export_id !(t.ex_table))
record_descr t id descr;
id
+ let new_value_closure_descr t ~closure_id ~set_of_closures =
+ match Closure_id.Map.find closure_id !(t.closure_table) with
+ | exception Not_found ->
+ let export_id =
+ new_descr t (Value_closure { closure_id; set_of_closures })
+ in
+ t.closure_table :=
+ Closure_id.Map.add closure_id export_id !(t.closure_table);
+ export_id
+ | export_id -> export_id
+
let new_unit_descr t =
new_descr t (Value_constptr 0)
[Project_closure]: closure ID %a not in set of closures"
Closure_id.print closure_id
end;
- let descr : Export_info.descr =
- Value_closure { closure_id = closure_id; set_of_closures; }
- in
- Value_id (Env.new_descr env descr)
+ Value_id (
+ Env.new_value_closure_descr env ~closure_id ~set_of_closures
+ )
| _ ->
(* It would be nice if this were [assert false], but owing to the fact
that this pass may propagate less information than for example
begin match Env.get_descr env (Env.find_approx env closure) with
| Some (Value_closure { set_of_closures; closure_id; }) ->
assert (Closure_id.equal closure_id start_from);
- let descr : Export_info.descr =
- Value_closure { closure_id = move_to; set_of_closures; }
- in
- Value_id (Env.new_descr env descr)
+ Value_id (
+ Env.new_value_closure_descr env ~closure_id:move_to ~set_of_closures
+ )
| _ -> Value_unknown
end
| Project_var { closure; closure_id = closure_id'; var; } ->
{ Export_info.
set_of_closures_id = set.function_decls.set_of_closures_id;
bound_vars = Var_within_closure.wrap_map bound_vars_approx;
+ free_vars = set.free_vars;
results =
Closure_id.wrap_map
(Variable.Map.map (fun _ -> Export_info.Value_unknown)
}
in
Variable.Map.mapi (fun fun_var _function_decl ->
- let descr : Export_info.descr =
- Value_closure
- { closure_id = Closure_id.wrap fun_var;
- set_of_closures = initial_value_set_of_closures;
- }
+ let export_id =
+ let closure_id = Closure_id.wrap fun_var in
+ let set_of_closures = initial_value_set_of_closures in
+ Env.new_value_closure_descr env ~closure_id ~set_of_closures
in
- Export_info.Value_id (Env.new_descr env descr))
+ Export_info.Value_id export_id)
set.function_decls.funs
in
let closure_env =
in
{ set_of_closures_id = set.function_decls.set_of_closures_id;
bound_vars = Var_within_closure.wrap_map bound_vars_approx;
+ free_vars = set.free_vars;
results = Closure_id.wrap_map results;
aliased_symbol = None;
}
in
loop env program.program_body
-let build_export_info ~(backend : (module Backend_intf.S))
- (program : Flambda.program) : Export_info.t =
+
+let build_transient ~(backend : (module Backend_intf.S))
+ (program : Flambda.program) : Export_info.transient =
if !Clflags.opaque then
- Export_info.empty
+ let compilation_unit = Compilenv.current_unit () in
+ let root_symbol = Compilenv.current_unit_symbol () in
+ Export_info.opaque_transient ~root_symbol ~compilation_unit
else
(* CR-soon pchambart: Should probably use that instead of the ident of
the module as global identifier.
let _global_symbol, env =
describe_program (Env.Global.create_empty ()) program
in
- let sets_of_closures =
- Flambda_utils.all_function_decls_indexed_by_set_of_closures_id program
+ let sets_of_closures_map =
+ Flambda_utils.all_sets_of_closures_map program
in
- let closures =
- Flambda_utils.all_function_decls_indexed_by_closure_id program
- in
- let invariant_params =
- Set_of_closures_id.Map.map
- (fun { Flambda. function_decls; _ } ->
- Invariant_params.invariant_params_in_recursion
- ~backend function_decls)
- (Flambda_utils.all_sets_of_closures_map program)
+ let function_declarations_map =
+ let set_of_closures_approx { Flambda. function_decls; _ } =
+ let recursive =
+ lazy
+ (Find_recursive_functions.in_function_declarations
+ function_decls ~backend)
+ in
+ let keep_body =
+ Inline_and_simplify_aux.keep_body_check
+ ~is_classic_mode:function_decls.is_classic_mode ~recursive
+ in
+ Simple_value_approx.function_declarations_approx
+ ~keep_body function_decls
+ in
+ Set_of_closures_id.Map.map set_of_closures_approx sets_of_closures_map
in
let unnested_values =
Env.Global.export_id_to_descr_map env
in
let invariant_params =
+ let invariant_params =
+ Set_of_closures_id.Map.map
+ (fun { Flambda. function_decls; _ } ->
+ if function_decls.is_classic_mode then begin
+ Variable.Map.empty
+ end else begin
+ Invariant_params.invariant_params_in_recursion
+ ~backend function_decls
+ end)
+ (Flambda_utils.all_sets_of_closures_map program)
+ in
let export = Compilenv.approx_env () in
- Export_id.Map.fold (fun _eid (descr:Export_info.descr)
- (invariant_params) ->
- match descr with
+ Export_id.Map.fold
+ (fun _eid (descr:Export_info.descr) invariant_params ->
+ match (descr : Export_info.descr) with
| Value_closure { set_of_closures }
| Value_set_of_closures set_of_closures ->
let { Export_info.set_of_closures_id } = set_of_closures in
with
| exception Not_found ->
invariant_params
- | (set:Variable.Set.t Variable.Map.t) ->
- Set_of_closures_id.Map.add set_of_closures_id set invariant_params
+ | (set : Variable.Set.t Variable.Map.t) ->
+ Set_of_closures_id.Map.add
+ set_of_closures_id set invariant_params
end
- | _ ->
+ | Export_info.Value_boxed_int (_, _)
+ | Value_block _
+ | Value_mutable_block _
+ | Value_int _
+ | Value_char _
+ | Value_constptr _
+ | Value_float _
+ | Value_float_array _
+ | Value_string _
+ | Value_unknown_descr ->
invariant_params)
unnested_values invariant_params
in
+ let recursive =
+ let recursive =
+ Set_of_closures_id.Map.map
+ (fun { Flambda. function_decls; _ } ->
+ if function_decls.is_classic_mode then begin
+ Variable.Set.empty
+ end else begin
+ Find_recursive_functions.in_function_declarations
+ ~backend function_decls
+ end)
+ (Flambda_utils.all_sets_of_closures_map program)
+ in
+ let export = Compilenv.approx_env () in
+ Export_id.Map.fold
+ (fun _eid (descr:Export_info.descr) recursive ->
+ match (descr : Export_info.descr) with
+ | Value_closure { set_of_closures }
+ | Value_set_of_closures set_of_closures ->
+ let { Export_info.set_of_closures_id } = set_of_closures in
+ begin match
+ Set_of_closures_id.Map.find set_of_closures_id
+ export.recursive
+ with
+ | exception Not_found ->
+ recursive
+ | (set : Variable.Set.t) ->
+ Set_of_closures_id.Map.add
+ set_of_closures_id set recursive
+ end
+ | Export_info.Value_boxed_int (_, _)
+ | Value_block _
+ | Value_mutable_block _
+ | Value_int _
+ | Value_char _
+ | Value_constptr _
+ | Value_float _
+ | Value_float_array _
+ | Value_string _
+ | Value_unknown_descr ->
+ recursive)
+ unnested_values recursive
+ in
+ let values = Export_info.nest_eid_map unnested_values in
+ let symbol_id = Env.Global.symbol_to_export_id_map env in
+ let { Traverse_for_exported_symbols.
+ set_of_closure_ids = relevant_set_of_closures;
+ symbols = relevant_symbols;
+ export_ids = relevant_export_ids;
+ set_of_closure_ids_keep_declaration =
+ relevant_set_of_closures_declaration_only;
+ relevant_local_closure_ids;
+ relevant_imported_closure_ids;
+ relevant_local_vars_within_closure;
+ relevant_imported_vars_within_closure;
+ } =
+ let closure_id_to_set_of_closures_id =
+ Set_of_closures_id.Map.fold
+ (fun set_of_closure_id
+ (function_declarations : Simple_value_approx.function_declarations) acc ->
+ Variable.Map.fold
+ (fun fun_var _ acc ->
+ let closure_id = Closure_id.wrap fun_var in
+ Closure_id.Map.add closure_id set_of_closure_id acc)
+ function_declarations.funs
+ acc)
+ function_declarations_map
+ Closure_id.Map.empty
+ in
+ Traverse_for_exported_symbols.traverse
+ ~sets_of_closures_map
+ ~closure_id_to_set_of_closures_id
+ ~function_declarations_map
+ ~values:(Compilation_unit.Map.find (Compilenv.current_unit ()) values)
+ ~symbol_id
+ ~root_symbol:(Compilenv.current_unit_symbol ())
+ in
+ let sets_of_closures =
+ Set_of_closures_id.Map.filter_map
+ function_declarations_map
+ ~f:(fun key (fun_decls : Simple_value_approx.function_declarations) ->
+ if Set_of_closures_id.Set.mem key relevant_set_of_closures then
+ Some fun_decls
+ else if begin
+ Set_of_closures_id.Set.mem key
+ relevant_set_of_closures_declaration_only
+ end then begin
+ if fun_decls.is_classic_mode then
+ Some (Simple_value_approx.clear_function_bodies fun_decls)
+ else
+ Some fun_decls
+ end else begin
+ None
+ end)
+ in
+
let values =
- Export_info.nest_eid_map unnested_values
+ Compilation_unit.Map.map (fun map ->
+ Export_id.Map.filter (fun key _ ->
+ Export_id.Set.mem key relevant_export_ids)
+ map)
+ values
in
- Export_info.create ~values
- ~symbol_id:(Env.Global.symbol_to_export_id_map env)
- ~offset_fun:Closure_id.Map.empty
- ~offset_fv:Var_within_closure.Map.empty
- ~sets_of_closures ~closures
- ~constant_sets_of_closures:Set_of_closures_id.Set.empty
+ let symbol_id =
+ Symbol.Map.filter
+ (fun key _ -> Symbol.Set.mem key relevant_symbols)
+ symbol_id
+ in
+ Export_info.create_transient ~values
+ ~symbol_id
+ ~sets_of_closures
~invariant_params
+ ~recursive
+ ~relevant_local_closure_ids
+ ~relevant_imported_closure_ids
+ ~relevant_local_vars_within_closure
+ ~relevant_imported_vars_within_closure
+
(** Construct export information, for emission into .cmx files, from an
Flambda program. *)
-val build_export_info :
+val build_transient :
backend:(module Backend_intf.S) ->
Flambda.program ->
- Export_info.t
+ Export_info.transient
(* Preallocated globals *)
+type uconstant_block_field =
+ | Uconst_field_ref of string
+ | Uconst_field_int of int
+
type preallocated_block = {
symbol : string;
exported : bool;
tag : int;
- size : int;
+ fields : uconstant_block_field option list;
}
type preallocated_constant = {
val compare_constants:
uconstant -> uconstant -> int
+type uconstant_block_field =
+ | Uconst_field_ref of string
+ | Uconst_field_int of int
+
type preallocated_block = {
symbol : string;
exported : bool;
tag : int;
- size : int;
+ fields : uconstant_block_field option list;
}
type preallocated_constant = {
| Parraysetu kind -> if kind = Pgenarray then 16 else 4
| Parrayrefs kind -> if kind = Pgenarray then 18 else 8
| Parraysets kind -> if kind = Pgenarray then 22 else 10
- | Pbittest -> 3
| Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6
| Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6
| _ -> 2 (* arithmetic and comparisons *)
let make_const_int n = make_const (Uconst_int n)
let make_const_ptr n = make_const (Uconst_ptr n)
let make_const_bool b = make_const_ptr(if b then 1 else 0)
-let make_comparison cmp x y =
+
+let make_integer_comparison cmp x y =
make_const_bool
(match cmp with
Ceq -> x = y
- | Cneq -> x <> y
+ | Cne -> x <> y
| Clt -> x < y
| Cgt -> x > y
| Cle -> x <= y
| Cge -> x >= y)
+
+let make_float_comparison cmp x y =
+ make_const_bool
+ (match cmp with
+ | CFeq -> x = y
+ | CFneq -> not (x = y)
+ | CFlt -> x < y
+ | CFnlt -> not (x < y)
+ | CFgt -> x > y
+ | CFngt -> not (x > y)
+ | CFle -> x <= y
+ | CFnle -> not (x <= y)
+ | CFge -> x >= y
+ | CFnge -> not (x >= y))
+
let make_const_float n = make_const_ref (Uconst_float n)
let make_const_natint n = make_const_ref (Uconst_nativeint n)
let make_const_int32 n = make_const_ref (Uconst_int32 n)
make_const_int (n1 lsr n2)
| Pasrint when 0 <= n2 && n2 < 8 * Arch.size_int ->
make_const_int (n1 asr n2)
- | Pintcomp c -> make_comparison c n1 n2
+ | Pintcomp c -> make_integer_comparison c n1 n2
| _ -> default
end
(* float *)
| Psubfloat -> make_const_float (n1 -. n2)
| Pmulfloat -> make_const_float (n1 *. n2)
| Pdivfloat -> make_const_float (n1 /. n2)
- | Pfloatcomp c -> make_comparison c n1 n2
+ | Pfloatcomp c -> make_float_comparison c n1 n2
| _ -> default
end
(* nativeint *)
| Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2)
| Porbint Pnativeint -> make_const_natint (Nativeint.logor n1 n2)
| Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2)
- | Pbintcomp(Pnativeint, c) -> make_comparison c n1 n2
+ | Pbintcomp(Pnativeint, c) -> make_integer_comparison c n1 n2
| _ -> default
end
(* nativeint, int *)
| Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2)
| Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2)
| Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2)
- | Pbintcomp(Pint32, c) -> make_comparison c n1 n2
+ | Pbintcomp(Pint32, c) -> make_integer_comparison c n1 n2
| _ -> default
end
(* int32, int *)
| Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2)
| Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2)
| Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2)
- | Pbintcomp(Pint64, c) -> make_comparison c n1 n2
+ | Pbintcomp(Pint64, c) -> make_integer_comparison c n1 n2
| _ -> default
end
(* int64, int *)
!function_nesting_depth < excessive_function_nesting_depth in
(* Determine the free variables of the functions *)
let fv =
- IdentSet.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in
+ Ident.Set.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in
(* Build the function descriptors for the functions.
Initially all functions are assumed not to need their environment
parameter. *)
(* First default case *)
begin match default with
| Some def when ncases < num_keys ->
- assert (store.act_store def = 0)
+ assert (store.act_store () def = 0)
| _ -> ()
end ;
(* Then all other cases *)
List.iter
(fun (key,lam) ->
- index.(key) <- store.act_store lam)
+ index.(key) <- store.act_store () lam)
cases ;
(* Explicit sharing with catch/exit, as switcher compilation may
init (Flambda_utils.all_sets_of_closures program)
in
r
-
-let compute_reexported_offsets program
- ~current_unit_offset_fun ~current_unit_offset_fv
- ~imported_units_offset_fun ~imported_units_offset_fv =
- let offset_fun = ref current_unit_offset_fun in
- let offset_fv = ref current_unit_offset_fv in
- let used_closure_id closure_id =
- match Closure_id.Map.find closure_id imported_units_offset_fun with
- | offset ->
- assert (not (Closure_id.Map.mem closure_id current_unit_offset_fun));
- begin match Closure_id.Map.find closure_id !offset_fun with
- | exception Not_found ->
- offset_fun := Closure_id.Map.add closure_id offset !offset_fun
- | offset' -> assert (offset = offset')
- end
- | exception Not_found ->
- assert (Closure_id.Map.mem closure_id current_unit_offset_fun)
- in
- let used_var_within_closure var =
- match Var_within_closure.Map.find var imported_units_offset_fv with
- | offset ->
- assert (not (Var_within_closure.Map.mem var current_unit_offset_fv));
- begin match Var_within_closure.Map.find var !offset_fv with
- | exception Not_found ->
- offset_fv := Var_within_closure.Map.add var offset !offset_fv
- | offset' -> assert (offset = offset')
- end
- | exception Not_found ->
- assert (Var_within_closure.Map.mem var current_unit_offset_fv)
- in
- Flambda_iterators.iter_named_of_program program
- ~f:(fun (named : Flambda.named) ->
- match named with
- | Project_closure { closure_id; _ } ->
- used_closure_id closure_id
- | Move_within_set_of_closures { start_from; move_to; _ } ->
- used_closure_id start_from;
- used_closure_id move_to
- | Project_var { closure_id; var; _ } ->
- used_closure_id closure_id;
- used_var_within_closure var
- | Symbol _ | Const _ | Allocated_const _ | Read_mutable _
- | Read_symbol_field _ | Set_of_closures _ | Prim _ | Expr _ -> ());
- Flambda_iterators.iter_constant_defining_values_on_program program
- ~f:(fun (const : Flambda.constant_defining_value) ->
- match const with
- | Project_closure (_, closure_id) -> used_closure_id closure_id
- | Allocated_const _ | Block _ | Set_of_closures _ -> ());
- !offset_fun, !offset_fv
}
val compute : Flambda.program -> result
-
-(** If compilation unit [C] references [B], which contains functions inlined
- from another compilation unit [A], then we may need to know the layout of
- closures inside (or constructed by code inside) a.cmx in order to
- compile c.cmx. Unfortunately a.cmx is permitted to be absent during such
- compilation; c.cmx will be compiled using just b.cmx. As such, when
- building the .cmx export information for a given compilation unit, we
- also include information about the layout of any closures that it depends
- on from other compilation units. This means that when situations as just
- describe arise, we always have access to the necessary closure offsets. *)
-val compute_reexported_offsets
- : Flambda.program
- -> current_unit_offset_fun:int Closure_id.Map.t
- -> current_unit_offset_fv:int Var_within_closure.Map.t
- -> imported_units_offset_fun:int Closure_id.Map.t
- -> imported_units_offset_fv:int Var_within_closure.Map.t
- -> int Closure_id.Map.t * int Var_within_closure.Map.t
done;
!size
-type comparison =
- Ceq
- | Cne
- | Clt
- | Cle
- | Cgt
- | Cge
-
-let negate_comparison = function
- Ceq -> Cne | Cne -> Ceq
- | Clt -> Cge | Cle -> Cgt
- | Cgt -> Cle | Cge -> Clt
-
-let swap_comparison = function
- Ceq -> Ceq | Cne -> Cne
- | Clt -> Cgt | Cle -> Cge
- | Cgt -> Clt | Cge -> Cle
+type integer_comparison = Lambda.integer_comparison =
+ | Ceq | Cne | Clt | Cgt | Cle | Cge
+let negate_integer_comparison = Lambda.negate_integer_comparison
+
+let swap_integer_comparison = Lambda.swap_integer_comparison
+
+(* With floats [not (x < y)] is not the same as [x >= y] due to NaNs,
+ so we provide additional comparisons to represent the negations.*)
+type float_comparison = Lambda.float_comparison =
+ | CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge
+
+let negate_float_comparison = Lambda.negate_float_comparison
+
+let swap_float_comparison = Lambda.swap_float_comparison
type label = int
let label_counter = ref 99
| Cstore of memory_chunk * Lambda.initialization_or_assignment
| Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi
| Cand | Cor | Cxor | Clsl | Clsr | Casr
- | Ccmpi of comparison
+ | Ccmpi of integer_comparison
| Caddv | Cadda
- | Ccmpa of comparison
+ | Ccmpa of integer_comparison
| Cnegf | Cabsf
| Caddf | Csubf | Cmulf | Cdivf
| Cfloatofint | Cintoffloat
- | Ccmpf of comparison
+ | Ccmpf of float_comparison
| Craise of raise_kind
| Ccheckbound
| Cexit of int * expression list
| Ctrywith of expression * Ident.t * expression
+type codegen_option =
+ | Reduce_code_size
+ | No_CSE
+
type fundecl =
{ fun_name: string;
fun_args: (Ident.t * machtype) list;
fun_body: expression;
- fun_fast: bool;
+ fun_codegen_options : codegen_option list;
fun_dbg : Debuginfo.t;
}
val size_machtype: machtype -> int
-type comparison =
- Ceq
- | Cne
- | Clt
- | Cle
- | Cgt
- | Cge
+type integer_comparison = Lambda.integer_comparison =
+ | Ceq | Cne | Clt | Cgt | Cle | Cge
-val negate_comparison: comparison -> comparison
-val swap_comparison: comparison -> comparison
+val negate_integer_comparison: integer_comparison -> integer_comparison
+val swap_integer_comparison: integer_comparison -> integer_comparison
+
+type float_comparison = Lambda.float_comparison =
+ | CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge
+
+val negate_float_comparison: float_comparison -> float_comparison
+val swap_float_comparison: float_comparison -> float_comparison
type label = int
val new_label: unit -> label
| Cstore of memory_chunk * Lambda.initialization_or_assignment
| Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi
| Cand | Cor | Cxor | Clsl | Clsr | Casr
- | Ccmpi of comparison
+ | Ccmpi of integer_comparison
| Caddv (* pointer addition that produces a [Val] (well-formed Caml value) *)
| Cadda (* pointer addition that produces a [Addr] (derived heap pointer) *)
- | Ccmpa of comparison
+ | Ccmpa of integer_comparison
| Cnegf | Cabsf
| Caddf | Csubf | Cmulf | Cdivf
| Cfloatofint | Cintoffloat
- | Ccmpf of comparison
+ | Ccmpf of float_comparison
| Craise of raise_kind
| Ccheckbound
| Cexit of int * expression list
| Ctrywith of expression * Ident.t * expression
+type codegen_option =
+ | Reduce_code_size
+ | No_CSE
+
type fundecl =
{ fun_name: string;
fun_args: (Ident.t * machtype) list;
fun_body: expression;
- fun_fast: bool;
+ fun_codegen_options : codegen_option list;
fun_dbg : Debuginfo.t;
}
| Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], dbg') -> begin
match c with
| Cop(Ccmpi cmp, [c1; c2], dbg'') ->
- tag_int (Cop(Ccmpi (negate_comparison cmp), [c1; c2], dbg'')) dbg'
+ tag_int
+ (Cop(Ccmpi (negate_integer_comparison cmp), [c1; c2], dbg'')) dbg'
| Cop(Ccmpa cmp, [c1; c2], dbg'') ->
- tag_int (Cop(Ccmpa (negate_comparison cmp), [c1; c2], dbg'')) dbg'
+ tag_int
+ (Cop(Ccmpa (negate_integer_comparison cmp), [c1; c2], dbg'')) dbg'
+ | Cop(Ccmpf cmp, [c1; c2], dbg'') ->
+ tag_int
+ (Cop(Ccmpf (negate_float_comparison cmp), [c1; c2], dbg'')) dbg'
| _ ->
(* 0 -> 3, 1 -> 1 *)
Cop(Csubi, [Cconst_int 3; Cop(Clsl, [c; Cconst_int 1], dbg)], dbg)
let set_field ptr n newval init dbg =
Cop(Cstore (Word_val, init), [field_address ptr n dbg; newval], dbg)
-let non_profinfo_mask = (1 lsl (64 - Config.profinfo_width)) - 1
+let non_profinfo_mask =
+ if Config.profinfo
+ then (1 lsl (64 - Config.profinfo_width)) - 1
+ else 0 (* [non_profinfo_mask] is unused in this case *)
let get_header ptr dbg =
(* We cannot deem this as [Immutable] due to the presence of [Obj.truncate]
(* Comparisons *)
-let transl_comparison = function
- Lambda.Ceq -> Ceq
- | Lambda.Cneq -> Cne
- | Lambda.Cge -> Cge
- | Lambda.Cgt -> Cgt
- | Lambda.Cle -> Cle
- | Lambda.Clt -> Clt
+let transl_int_comparison cmp = cmp
+
+let transl_float_comparison cmp = cmp
(* Translate structured constants *)
and elt_size =
bigarray_elt_size elt_kind in
(* [array_indexing] can simplify the given expressions *)
- array_indexing ~typ:Int (log2 elt_size)
+ array_indexing ~typ:Addr (log2 elt_size)
(Cop(Cload (Word_int, Mutable),
[field_address b 1 dbg], dbg)) offset dbg
Pbigarray_complex32 | Pbigarray_complex64 ->
let kind = bigarray_word_kind elt_kind in
let sz = bigarray_elt_size elt_kind / 2 in
- bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg)
- (fun addr ->
- box_complex dbg
- (Cop(Cload (kind, Mutable), [addr], dbg))
- (Cop(Cload (kind, Mutable),
- [Cop(Cadda, [addr; Cconst_int sz], dbg)], dbg)))
+ bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
+ bind "reval"
+ (Cop(Cload (kind, Mutable), [addr], dbg)) (fun reval ->
+ bind "imval"
+ (Cop(Cload (kind, Mutable),
+ [Cop(Cadda, [addr; Cconst_int sz], dbg)], dbg)) (fun imval ->
+ box_complex dbg reval imval)))
| _ ->
Cop(Cload (bigarray_word_kind elt_kind, Mutable),
[bigarray_indexing unsafe elt_kind layout b args dbg],
| Plsrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right_unsigned")
| Pasrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right")
| Pbintcomp(Pint64, Lambda.Ceq) -> Pccall (default_prim "caml_equal")
- | Pbintcomp(Pint64, Lambda.Cneq) -> Pccall (default_prim "caml_notequal")
+ | Pbintcomp(Pint64, Lambda.Cne) -> Pccall (default_prim "caml_notequal")
| Pbintcomp(Pint64, Lambda.Clt) -> Pccall (default_prim "caml_lessthan")
| Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan")
| Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal")
| Pbigarrayset(_unsafe, n, Pbigarray_int64, _layout) ->
Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
| Pstring_load_64(_) -> Pccall (default_prim "caml_string_get64")
- | Pstring_set_64(_) -> Pccall (default_prim "caml_string_set64")
+ | Pbytes_load_64(_) -> Pccall (default_prim "caml_bytes_get64")
+ | Pbytes_set_64(_) -> Pccall (default_prim "caml_bytes_set64")
| Pbigstring_load_64(_) -> Pccall (default_prim "caml_ba_uint8_get64")
| Pbigstring_set_64(_) -> Pccall (default_prim "caml_ba_uint8_set64")
| Pbbswap Pint64 -> Pccall (default_prim "caml_int64_bswap")
(* cmm store, as sharing as normally been detected in previous
phases, we only share exits *)
+(* Some specific patterns can lead to switches where several cases
+ point to the same action, but this action is not an exit (see GPR#1370).
+ The addition of the index in the action array as context allows to
+ share them correctly without duplication. *)
+module StoreExpForSwitch =
+ Switch.CtxStore
+ (struct
+ type t = expression
+ type key = int option * int
+ type context = int
+ let make_key index expr =
+ let continuation =
+ match expr with
+ | Cexit (i,[]) -> Some i
+ | _ -> None
+ in
+ Some (continuation, index)
+ let compare_key (cont, index) (cont', index') =
+ match cont, cont' with
+ | Some i, Some i' when i = i' -> 0
+ | _, _ -> Pervasives.compare index index'
+ end)
+
+(* For string switches, we can use a generic store *)
module StoreExp =
Switch.Store
(struct
| [] -> assert false
| _::_ ->
let store = StoreExp.mk_store () in
- assert (store.Switch.act_store default = 0) ;
+ assert (store.Switch.act_store () default = 0) ;
let cases =
List.map
- (fun (i,act) -> i,store.Switch.act_store act)
+ (fun (i,act) -> i,store.Switch.act_store () act)
cases in
let rec inters plow phigh pact = function
| [] ->
Boxed (Boxed_integer (Pint64, dbg), false)
| Pbigarrayref(_, _, Pbigarray_native_int,_) ->
Boxed (Boxed_integer (Pnativeint, dbg), false)
- | Pstring_load_32(_) -> Boxed (Boxed_integer (Pint32, dbg), false)
- | Pstring_load_64(_) -> Boxed (Boxed_integer (Pint64, dbg), false)
+ | Pstring_load_32(_) | Pbytes_load_32(_) ->
+ Boxed (Boxed_integer (Pint32, dbg), false)
+ | Pstring_load_64(_) | Pbytes_load_64(_) ->
+ Boxed (Boxed_integer (Pint64, dbg), false)
| Pbigstring_load_32(_) -> Boxed (Boxed_integer (Pint32, dbg), false)
| Pbigstring_load_64(_) -> Boxed (Boxed_integer (Pint64, dbg), false)
| Praise _ -> No_result
Cop(Cor, [asr_int (transl env arg1) (untag_int(transl env arg2) dbg) dbg;
Cconst_int 1], dbg)
| Pintcomp cmp ->
- tag_int(Cop(Ccmpi(transl_comparison cmp),
+ tag_int(Cop(Ccmpi(transl_int_comparison cmp),
[transl env arg1; transl env arg2], dbg)) dbg
| Pisout ->
transl_isout (transl env arg1) (transl env arg2) dbg
[transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2],
dbg))
| Pfloatcomp cmp ->
- tag_int(Cop(Ccmpf(transl_comparison cmp),
+ tag_int(Cop(Ccmpf(transl_float_comparison cmp),
[transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2],
dbg)) dbg
Cop(Cload (Byte_unsigned, Mutable),
[add_int str idx dbg], dbg))))) dbg
- | Pstring_load_16(unsafe) ->
+ | Pstring_load_16(unsafe) | Pbytes_load_16(unsafe) ->
tag_int
(bind "str" (transl env arg1) (fun str ->
bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
(Cconst_int 1) dbg) idx
(unaligned_load_16 ba_data idx dbg))))) dbg
- | Pstring_load_32(unsafe) ->
+ | Pstring_load_32(unsafe) | Pbytes_load_32(unsafe) ->
box_int dbg Pint32
(bind "str" (transl env arg1) (fun str ->
bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
(Cconst_int 3) dbg) idx
(unaligned_load_32 ba_data idx dbg)))))
- | Pstring_load_64(unsafe) ->
+ | Pstring_load_64(unsafe) | Pbytes_load_64(unsafe) ->
box_int dbg Pint64
(bind "str" (transl env arg1) (fun str ->
bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
unboxed_float_array_ref arr idx dbg))))
end
- (* Operations on bitvects *)
- | Pbittest ->
- bind "index" (untag_int(transl env arg2) dbg) (fun idx ->
- tag_int(
- Cop(Cand, [Cop(Clsr, [Cop(Cload (Byte_unsigned, Mutable),
- [add_int (transl env arg1)
- (Cop(Clsr, [idx; Cconst_int 3], dbg))
- dbg],
- dbg);
- Cop(Cand, [idx; Cconst_int 7], dbg)], dbg);
- Cconst_int 1], dbg)) dbg)
-
(* Boxed integers *)
| Paddbint bi ->
box_int dbg bi (Cop(Caddi,
[transl_unbox_int dbg env bi arg1;
untag_int(transl env arg2) dbg], dbg))
| Pbintcomp(bi, cmp) ->
- tag_int (Cop(Ccmpi(transl_comparison cmp),
+ tag_int (Cop(Ccmpi(transl_int_comparison cmp),
[transl_unbox_int dbg env bi arg1;
transl_unbox_int dbg env bi arg2], dbg)) dbg
| prim ->
float_array_set arr idx newval dbg))))
end)
- | Pstring_set_16(unsafe) ->
+ | Pbytes_set_16(unsafe) ->
return_unit
(bind "str" (transl env arg1) (fun str ->
bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
dbg)
idx (unaligned_set_16 ba_data idx newval dbg))))))
- | Pstring_set_32(unsafe) ->
+ | Pbytes_set_32(unsafe) ->
return_unit
(bind "str" (transl env arg1) (fun str ->
bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
dbg)
idx (unaligned_set_32 ba_data idx newval dbg))))))
- | Pstring_set_64(unsafe) ->
+ | Pbytes_set_64(unsafe) ->
return_unit
(bind "str" (transl env arg1) (fun str ->
bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
| 1 -> transl env cases.(0)
| _ ->
let cases = Array.map (transl env) cases in
- let store = StoreExp.mk_store () in
+ let store = StoreExpForSwitch.mk_store () in
let index =
Array.map
- (fun j -> store.Switch.act_store cases.(j))
+ (fun j -> store.Switch.act_store j cases.(j))
index in
let n_index = Array.length index in
let inters = ref []
Afl_instrument.instrument_function (transl env body)
else
transl env body in
+ let fun_codegen_options =
+ if !Clflags.optimize_for_speed then
+ []
+ else
+ [ Reduce_code_size ]
+ in
Cfunction {fun_name = f.label;
fun_args = List.map (fun id -> (id, typ_val)) f.params;
fun_body = cmm_body;
- fun_fast = !Clflags.optimize_for_speed;
+ fun_codegen_options;
fun_dbg = f.dbg}
(* Translate all function definitions *)
(* Build preallocated blocks (used for Flambda [Initialize_symbol]
constructs, and Clambda global module) *)
-let preallocate_block cont { Clambda.symbol; exported; tag; size } =
+let preallocate_block cont { Clambda.symbol; exported; tag; fields } =
let space =
(* These words will be registered as roots and as such must contain
valid values, in case we are in no-naked-pointers mode. Likewise
the block header must be black, below (see [caml_darken]), since
the overall record may be referenced. *)
- Array.to_list
- (Array.init size (fun _index ->
- Cint (Nativeint.of_int 1 (* Val_unit *))))
+ List.map (fun field ->
+ match field with
+ | None ->
+ Cint (Nativeint.of_int 1 (* Val_unit *))
+ | Some (Uconst_field_int n) ->
+ cint_const n
+ | Some (Uconst_field_ref label) ->
+ Csymbol_address label)
+ fields
in
let data =
- Cint(black_block_header tag size) ::
+ Cint(black_block_header tag (List.length fields)) ::
if exported then
Cglobal_symbol symbol ::
Cdefine_symbol symbol :: space
transl empty_env ulam in
let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry");
fun_args = [];
- fun_body = init_code; fun_fast = false;
+ fun_body = init_code;
+ (* This function is often large and run only once.
+ Compilation time matter more than runtime.
+ See MPR#7630 *)
+ fun_codegen_options =
+ if Config.flambda then [
+ Reduce_code_size;
+ No_CSE;
+ ]
+ else [ Reduce_code_size ];
fun_dbg = Debuginfo.none }] in
let c2 = emit_constants c1 constants in
let c3 = transl_all_functions_and_emit_all_constants c2 in
{fun_name;
fun_args = fun_args;
fun_body = body;
- fun_fast = true;
+ fun_codegen_options = [];
fun_dbg = Debuginfo.none }
let apply_function arity =
{fun_name;
fun_args = List.map (fun id -> (id, typ_val)) all_args;
fun_body = body;
- fun_fast = true;
+ fun_codegen_options = [];
fun_dbg = Debuginfo.none;
}
Cop(Capply typ_val,
get_field env (Cvar clos) 2 dbg :: access_components 0 @ [Cvar clos],
dbg);
- fun_fast = true;
+ fun_codegen_options = [];
fun_dbg = Debuginfo.none;
}
"_" ^ string_of_int (arity-1);
fun_args = [last_arg, typ_val; last_clos, typ_val];
fun_body = curry_fun [] last_clos (arity-1);
- fun_fast = true;
+ fun_codegen_options = [];
fun_dbg = Debuginfo.none }
let rec intermediate_curry_functions arity num =
Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
int_const 1; Cvar arg; Cvar clos],
dbg);
- fun_fast = true;
+ fun_codegen_options = [];
fun_dbg = Debuginfo.none }
::
(if arity <= max_arity_optimized && arity - num > 2 then
fun_args = direct_args @ [clos, typ_val];
fun_body = iter (num+1)
(List.map (fun (arg,_) -> Cvar arg) direct_args) clos;
- fun_fast = true;
+ fun_codegen_options = [];
fun_dbg = Debuginfo.none }
in
cf :: intermediate_curry_functions arity (num+1)
Cfunction {fun_name = "caml_program";
fun_args = [];
fun_body = body;
- fun_fast = false;
+ fun_codegen_options = [Reduce_code_size];
fun_dbg = Debuginfo.none }
(* Generate the table of globals *)
let imported_sets_of_closures_table =
(Set_of_closures_id.Tbl.create 10
- : Flambda.function_declarations option Set_of_closures_id.Tbl.t)
+ : Simple_value_approx.function_declarations option
+ Set_of_closures_id.Tbl.t)
module CstMap =
Map.Make(struct
let current_unit_name () =
current_unit.ui_name
-let make_symbol ?(unitname = current_unit.ui_symbol) idopt =
- let prefix = "caml" ^ unitname in
- match idopt with
- | None -> prefix
- | Some id -> prefix ^ "__" ^ id
-
let symbol_in_current_unit name =
let prefix = "caml" ^ current_unit.ui_symbol in
name = prefix ||
let symbol_for_global' id =
let sym_label = Linkage_name.create (symbol_for_global id) in
if Ident.is_predef_exn id then
- Symbol.unsafe_create predefined_exception_compilation_unit sym_label
+ Symbol.of_global_linkage predefined_exception_compilation_unit sym_label
else
- Symbol.unsafe_create (unit_for_global id) sym_label
+ Symbol.of_global_linkage (unit_for_global id) sym_label
let set_global_approx approx =
assert(not Config.flambda);
|| not (Ident.global id)
then invalid_arg (Format.asprintf "approx_for_global %a" Ident.print id);
let modname = Ident.name id in
- try Hashtbl.find export_infos_table modname with
- | Not_found ->
- let exported = match get_global_info id with
- | None -> Export_info.empty
- | Some ui -> get_flambda_export_info ui in
- Hashtbl.add export_infos_table modname exported;
- merged_environment := Export_info.merge !merged_environment exported;
- exported
+ match Hashtbl.find export_infos_table modname with
+ | otherwise -> Some otherwise
+ | exception Not_found ->
+ match get_global_info id with
+ | None -> None
+ | Some ui ->
+ let exported = get_flambda_export_info ui in
+ Hashtbl.add export_infos_table modname exported;
+ merged_environment := Export_info.merge !merged_environment exported;
+ Some exported
let approx_env () = !merged_environment
current_unit.ui_imports_cmi <- Env.imports();
write_unit_info current_unit filename
-let current_unit_linkage_name () =
- Linkage_name.create (make_symbol ~unitname:current_unit.ui_symbol None)
-
let current_unit () =
match Compilation_unit.get_current () with
| Some current_unit -> current_unit
| None -> Misc.fatal_error "Compilenv.current_unit"
let current_unit_symbol () =
- Symbol.unsafe_create (current_unit ()) (current_unit_linkage_name ())
+ Symbol.of_global_linkage (current_unit ()) (current_unit_linkage_name ())
let const_label = ref 0
let linkage_name =
concat_symbol unitname ((Closure_id.unique_name fv) ^ "_closure")
in
- Symbol.unsafe_create compilation_unit (Linkage_name.create linkage_name)
+ Symbol.of_global_linkage compilation_unit (Linkage_name.create linkage_name)
let function_label fv =
let compilation_unit = Closure_id.get_compilation_unit fv in
improvement feature.
*)
val imported_sets_of_closures_table
- : Flambda.function_declarations option Set_of_closures_id.Tbl.t
+ : Simple_value_approx.function_declarations option Set_of_closures_id.Tbl.t
(* flambda-only *)
val reset: ?packname:string -> string -> unit
val approx_env: unit -> Export_info.t
(* Returns all the information loaded from external compilation units
flambda-only *)
-val approx_for_global: Compilation_unit.t -> Export_info.t
+val approx_for_global: Compilation_unit.t -> Export_info.t option
(* Loads the exported information declaring the compilation_unit
flambda-only *)
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+module A = Simple_value_approx
+
type value_string_contents =
| Contents of string
| Unknown_or_mutable
| Value_constptr of int
| Value_float of float
| Value_float_array of value_float_array
- | Value_boxed_int : 'a Simple_value_approx.boxed_int * 'a -> descr
+ | Value_boxed_int : 'a A.boxed_int * 'a -> descr
| Value_string of value_string
| Value_closure of value_closure
| Value_set_of_closures of value_set_of_closures
+ | Value_unknown_descr
and value_closure = {
closure_id : Closure_id.t;
and value_set_of_closures = {
set_of_closures_id : Set_of_closures_id.t;
bound_vars : approx Var_within_closure.Map.t;
+ free_vars : Flambda.specialised_to Variable.Map.t;
results : approx Closure_id.Map.t;
aliased_symbol : Symbol.t option;
}
let equal_descr (d1:descr) (d2:descr) : bool =
match d1, d2 with
+ | Value_unknown_descr, Value_unknown_descr ->
+ true
| Value_block (t1, f1), Value_block (t2, f2) ->
Tag.equal t1 t2 && equal_array equal_approx f1 f2
| Value_mutable_block (t1, s1), Value_mutable_block (t2, s2) ->
| Value_float_array s1, Value_float_array s2 ->
s1 = s2
| Value_boxed_int (t1, v1), Value_boxed_int (t2, v2) ->
- Simple_value_approx.equal_boxed_int t1 v1 t2 v2
+ A.equal_boxed_int t1 v1 t2 v2
| Value_string s1, Value_string s2 ->
s1 = s2
| Value_closure c1, Value_closure c2 ->
| ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _
| Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _
| Value_boxed_int _ | Value_string _ | Value_closure _
- | Value_set_of_closures _ ),
+ | Value_set_of_closures _
+ | Value_unknown_descr ),
( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _
| Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _
| Value_boxed_int _ | Value_string _ | Value_closure _
- | Value_set_of_closures _ ) ->
+ | Value_set_of_closures _
+ | Value_unknown_descr ) ->
false
type t = {
- sets_of_closures : Flambda.function_declarations Set_of_closures_id.Map.t;
- closures : Flambda.function_declarations Closure_id.Map.t;
+ sets_of_closures : A.function_declarations Set_of_closures_id.Map.t;
values : descr Export_id.Map.t Compilation_unit.Map.t;
symbol_id : Export_id.t Symbol.Map.t;
offset_fun : int Closure_id.Map.t;
offset_fv : int Var_within_closure.Map.t;
- constant_sets_of_closures : Set_of_closures_id.Set.t;
+ constant_closures : Closure_id.Set.t;
+ invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
+ recursive : Variable.Set.t Set_of_closures_id.Map.t;
+}
+
+type transient = {
+ sets_of_closures : A.function_declarations Set_of_closures_id.Map.t;
+ values : descr Export_id.Map.t Compilation_unit.Map.t;
+ symbol_id : Export_id.t Symbol.Map.t;
invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
+ recursive : Variable.Set.t Set_of_closures_id.Map.t;
+ relevant_local_closure_ids : Closure_id.Set.t;
+ relevant_imported_closure_ids : Closure_id.Set.t;
+ relevant_local_vars_within_closure : Var_within_closure.Set.t;
+ relevant_imported_vars_within_closure : Var_within_closure.Set.t;
}
let empty : t = {
sets_of_closures = Set_of_closures_id.Map.empty;
- closures = Closure_id.Map.empty;
values = Compilation_unit.Map.empty;
symbol_id = Symbol.Map.empty;
offset_fun = Closure_id.Map.empty;
offset_fv = Var_within_closure.Map.empty;
- constant_sets_of_closures = Set_of_closures_id.Set.empty;
+ constant_closures = Closure_id.Set.empty;
invariant_params = Set_of_closures_id.Map.empty;
+ recursive = Set_of_closures_id.Map.empty;
}
-let create ~sets_of_closures ~closures ~values ~symbol_id
- ~offset_fun ~offset_fv ~constant_sets_of_closures
- ~invariant_params =
+let opaque_transient ~compilation_unit ~root_symbol : transient =
+ let export_id = Export_id.create compilation_unit in
+ let values =
+ let map = Export_id.Map.singleton export_id Value_unknown_descr in
+ Compilation_unit.Map.singleton compilation_unit map
+ in
+ let symbol_id = Symbol.Map.singleton root_symbol export_id in
+ { sets_of_closures = Set_of_closures_id.Map.empty;
+ values;
+ symbol_id;
+ invariant_params = Set_of_closures_id.Map.empty;
+ recursive = Set_of_closures_id.Map.empty;
+ relevant_local_closure_ids = Closure_id.Set.empty;
+ relevant_imported_closure_ids = Closure_id.Set.empty;
+ relevant_local_vars_within_closure = Var_within_closure.Set.empty;
+ relevant_imported_vars_within_closure = Var_within_closure.Set.empty;
+ }
+
+let create ~sets_of_closures ~values ~symbol_id
+ ~offset_fun ~offset_fv ~constant_closures
+ ~invariant_params ~recursive =
{ sets_of_closures;
- closures;
values;
symbol_id;
offset_fun;
offset_fv;
- constant_sets_of_closures;
+ constant_closures;
invariant_params;
+ recursive;
}
-let add_clambda_info t ~offset_fun ~offset_fv ~constant_sets_of_closures =
- assert (Closure_id.Map.cardinal t.offset_fun = 0);
- assert (Var_within_closure.Map.cardinal t.offset_fv = 0);
- assert (Set_of_closures_id.Set.cardinal t.constant_sets_of_closures = 0);
- { t with offset_fun; offset_fv; constant_sets_of_closures; }
+let create_transient
+ ~sets_of_closures ~values ~symbol_id ~invariant_params ~recursive
+ ~relevant_local_closure_ids ~relevant_imported_closure_ids
+ ~relevant_local_vars_within_closure
+ ~relevant_imported_vars_within_closure =
+ { sets_of_closures;
+ values;
+ symbol_id;
+ invariant_params;
+ recursive;
+ relevant_local_closure_ids;
+ relevant_imported_closure_ids;
+ relevant_local_vars_within_closure;
+ relevant_imported_vars_within_closure;
+ }
+
+let t_of_transient transient
+ ~program:_
+ ~local_offset_fun ~local_offset_fv
+ ~imported_offset_fun ~imported_offset_fv
+ ~constant_closures =
+ let offset_fun =
+ let fold_map set =
+ Closure_id.Map.fold (fun key value unchanged ->
+ if Closure_id.Set.mem key set then
+ Closure_id.Map.add key value unchanged
+ else
+ unchanged)
+ in
+ Closure_id.Map.empty
+ |> fold_map transient.relevant_local_closure_ids local_offset_fun
+ |> fold_map transient.relevant_imported_closure_ids imported_offset_fun
+ in
+ let offset_fv =
+ let fold_map set =
+ Var_within_closure.Map.fold (fun key value unchanged ->
+ if Var_within_closure.Set.mem key set then
+ Var_within_closure.Map.add key value unchanged
+ else
+ unchanged)
+ in
+ Var_within_closure.Map.empty
+ |> fold_map transient.relevant_local_vars_within_closure local_offset_fv
+ |> fold_map transient.relevant_imported_vars_within_closure
+ imported_offset_fv
+ in
+ { sets_of_closures = transient.sets_of_closures;
+ values = transient.values;
+ symbol_id = transient.symbol_id;
+ invariant_params = transient.invariant_params;
+ recursive = transient.recursive;
+ offset_fun;
+ offset_fv;
+ constant_closures;
+ }
let merge (t1 : t) (t2 : t) : t =
let eidmap_disjoint_union ?eq map1 map2 =
sets_of_closures =
Set_of_closures_id.Map.disjoint_union t1.sets_of_closures
t2.sets_of_closures;
- closures = Closure_id.Map.disjoint_union t1.closures t2.closures;
symbol_id = Symbol.Map.disjoint_union ~print:Export_id.print t1.symbol_id t2.symbol_id;
offset_fun = Closure_id.Map.disjoint_union
~eq:int_eq t1.offset_fun t2.offset_fun;
offset_fv = Var_within_closure.Map.disjoint_union
~eq:int_eq t1.offset_fv t2.offset_fv;
- constant_sets_of_closures =
- Set_of_closures_id.Set.union t1.constant_sets_of_closures
- t2.constant_sets_of_closures;
+ constant_closures =
+ Closure_id.Set.union t1.constant_closures t2.constant_closures;
invariant_params =
Set_of_closures_id.Map.disjoint_union
~print:(Variable.Map.print Variable.Set.print)
~eq:(Variable.Map.equal Variable.Set.equal)
t1.invariant_params t2.invariant_params;
+ recursive =
+ Set_of_closures_id.Map.disjoint_union
+ ~print:Variable.Set.print
+ ~eq:Variable.Set.equal
+ t1.recursive t2.recursive;
}
let find_value eid map =
in
Export_id.Map.fold add_map map Compilation_unit.Map.empty
-let print_approx ppf ((t,root_symbols) : t * Symbol.t list) =
- let values = t.values in
+let print_raw_approx ppf approx =
+ let fprintf = Format.fprintf in
+ match approx with
+ | Value_unknown -> fprintf ppf "(Unknown)"
+ | Value_id export_id -> fprintf ppf "(Id %a)" Export_id.print export_id
+ | Value_symbol symbol -> fprintf ppf "(Symbol %a)" Symbol.print symbol
+
+let print_value_set_of_closures ppf (t : value_set_of_closures) =
+ let print_bound_vars ppf bound_vars =
+ Format.fprintf ppf "(%a)"
+ (Var_within_closure.Map.print print_raw_approx)
+ bound_vars
+ in
+ let print_free_vars ppf free_vars =
+ Format.fprintf ppf "(%a)"
+ (Variable.Map.print Flambda.print_specialised_to)
+ free_vars
+ in
+ let print_results ppf results =
+ Format.fprintf ppf "(%a)" (Closure_id.Map.print print_raw_approx) results
+ in
+ let print_aliased_symbol ppf aliased_symbol =
+ match aliased_symbol with
+ | None -> Format.fprintf ppf "<None>"
+ | Some symbol -> Format.fprintf ppf "(%a)" Symbol.print symbol
+ in
+ Format.fprintf ppf
+ "((set_of_closures_id %a) \
+ (bound_vars %a) \
+ (free_vars %a) \
+ (results %a) \
+ (aliased_symbol %a))"
+ Set_of_closures_id.print t.set_of_closures_id
+ print_bound_vars t.bound_vars
+ print_free_vars t.free_vars
+ print_results t.results
+ print_aliased_symbol t.aliased_symbol
+
+let print_value_closure ppf (t : value_closure) =
+ Format.fprintf ppf "((closure_id %a) (set_of_closures %a))"
+ Closure_id.print t.closure_id
+ print_value_set_of_closures t.set_of_closures
+
+let print_value_float_array_contents
+ ppf (value : value_float_array_contents) =
+ match value with
+ | Unknown_or_mutable -> Format.fprintf ppf "(Unknown_or_mutable)"
+ | Contents _ -> Format.fprintf ppf "(Contents ...)"
+
+let print_value_float_array ppf (value : value_float_array) =
+ Format.fprintf ppf "((size %d) (contents %a))"
+ value.size
+ print_value_float_array_contents value.contents
+
+let print_value_string_contents ppf (value : value_string_contents) =
+ match value with
+ | Unknown_or_mutable -> Format.fprintf ppf "(Unknown_or_mutable)"
+ | Contents _ -> Format.fprintf ppf "(Contents ...)"
+
+let print_value_string ppf (value : value_string) =
+ Format.fprintf ppf "((size %d) (contents %a))"
+ value.size
+ print_value_string_contents value.contents
+
+let print_raw_descr ppf descr =
+ let fprintf = Format.fprintf in
+ let print_approx_array ppf arr =
+ Array.iter (fun approx -> fprintf ppf "%a " print_raw_approx approx) arr
+ in
+ match descr with
+ | Value_block (tag, approx_array) ->
+ fprintf ppf "(Value_block (%a %a))"
+ Tag.print tag
+ print_approx_array approx_array
+ | Value_mutable_block (tag, i) ->
+ fprintf ppf "(Value_mutable-block (%a %d))" Tag.print tag i
+ | Value_int i -> fprintf ppf "(Value_int %d)" i
+ | Value_char c -> fprintf ppf "(Value_char %c)" c
+ | Value_constptr p -> fprintf ppf "(Value_constptr %d)" p
+ | Value_float f -> fprintf ppf "(Value_float %.3f)" f
+ | Value_float_array value_float_array ->
+ fprintf ppf "(Value_float_array %a)"
+ print_value_float_array value_float_array
+ | Value_boxed_int _ ->
+ fprintf ppf "(Value_Boxed_int)"
+ | Value_string value_string ->
+ fprintf ppf "(Value_string %a)" print_value_string value_string
+ | Value_closure value_closure ->
+ fprintf ppf "(Value_closure %a)"
+ print_value_closure value_closure
+ | Value_set_of_closures value_set_of_closures ->
+ fprintf ppf "(Value_set_of_closures %a)"
+ print_value_set_of_closures value_set_of_closures
+ | Value_unknown_descr -> fprintf ppf "(Value_unknown_descr)"
+
+let print_approx_components ppf ~symbol_id ~values
+ (root_symbols : Symbol.t list) =
let fprintf = Format.fprintf in
let printed = ref Export_id.Set.empty in
let recorded_symbol = ref Symbol.Set.empty in
| Contents _ -> "_imm")
float_array.size
| Value_boxed_int (t, i) ->
- let module A = Simple_value_approx in
- match t with
+ begin match t with
| A.Int32 -> Format.fprintf ppf "%li" i
| A.Int64 -> Format.fprintf ppf "%Li" i
| A.Nativeint -> Format.fprintf ppf "%ni" i
+ end
+ | Value_unknown_descr -> Format.fprintf ppf "?"
and print_fields ppf fields =
Array.iter (fun approx -> fprintf ppf "%a@ " print_approx approx) fields
and print_set_of_closures ppf
let rec print_recorded_symbols () =
if not (Queue.is_empty symbols_to_print) then begin
let sym = Queue.pop symbols_to_print in
- begin match Symbol.Map.find sym t.symbol_id with
+ begin match Symbol.Map.find sym symbol_id with
| exception Not_found -> ()
| id ->
fprintf ppf "@[<hov 2>%a:@ %a@];@ "
print_recorded_symbols ();
fprintf ppf "@]"
+let print_approx ppf ((t : t), symbols) =
+ let symbol_id = t.symbol_id in
+ let values = t.values in
+ print_approx_components ppf ~symbol_id ~values symbols
+
let print_offsets ppf (t : t) =
Format.fprintf ppf "@[<v 2>offset_fun:@ ";
Closure_id.Map.iter (fun cid off ->
Format.fprintf ppf "@]@ "
let print_functions ppf (t : t) =
- Set_of_closures_id.Map.print Flambda.print_function_declarations ppf
+ Set_of_closures_id.Map.print
+ A.print_function_declarations ppf
t.sets_of_closures
let print_all ppf ((t, root_symbols) : t * Symbol.t list) =
(** Exported information (that is to say, information written into a .cmx
file) about a compilation unit. *)
+module A = Simple_value_approx
+
type value_string_contents =
| Contents of string
| Unknown_or_mutable
| Value_constptr of int
| Value_float of float
| Value_float_array of value_float_array
- | Value_boxed_int : 'a Simple_value_approx.boxed_int * 'a -> descr
+ | Value_boxed_int : 'a A.boxed_int * 'a -> descr
| Value_string of value_string
| Value_closure of value_closure
| Value_set_of_closures of value_set_of_closures
+ | Value_unknown_descr
and value_closure = {
closure_id : Closure_id.t;
and value_set_of_closures = {
set_of_closures_id : Set_of_closures_id.t;
bound_vars : approx Var_within_closure.Map.t;
+ free_vars : Flambda.specialised_to Variable.Map.t;
results : approx Closure_id.Map.t;
aliased_symbol : Symbol.t option;
}
(** A structure that describes what a single compilation unit exports. *)
type t = private {
- sets_of_closures : Flambda.function_declarations Set_of_closures_id.Map.t;
+ sets_of_closures : A.function_declarations Set_of_closures_id.Map.t;
(** Code of exported functions indexed by set of closures IDs. *)
- closures : Flambda.function_declarations Closure_id.Map.t;
- (** Code of exported functions indexed by closure IDs. *)
values : descr Export_id.Map.t Compilation_unit.Map.t;
(** Structure of exported values. *)
symbol_id : Export_id.t Symbol.Map.t;
(** Positions of function pointers in their closures. *)
offset_fv : int Var_within_closure.Map.t;
(** Positions of value pointers in their closures. *)
- constant_sets_of_closures : Set_of_closures_id.Set.t;
+ constant_closures : Closure_id.Set.t;
(* CR-soon mshinwell for pchambart: Add comment *)
invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
(* Function parameters known to be invariant (see [Invariant_params])
indexed by set of closures ID. *)
+ recursive : Variable.Set.t Set_of_closures_id.Map.t;
+}
+
+type transient = private {
+ sets_of_closures : A.function_declarations Set_of_closures_id.Map.t;
+ values : descr Export_id.Map.t Compilation_unit.Map.t;
+ symbol_id : Export_id.t Symbol.Map.t;
+ invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
+ recursive : Variable.Set.t Set_of_closures_id.Map.t;
+ relevant_local_closure_ids : Closure_id.Set.t;
+ relevant_imported_closure_ids : Closure_id.Set.t;
+ relevant_local_vars_within_closure : Var_within_closure.Set.t;
+ relevant_imported_vars_within_closure : Var_within_closure.Set.t;
}
(** Export information for a compilation unit that exports nothing. *)
val empty : t
+val opaque_transient
+ : compilation_unit:Compilation_unit.t
+ -> root_symbol:Symbol.t
+ -> transient
+
(** Create a new export information structure. *)
val create
- : sets_of_closures:Flambda.function_declarations Set_of_closures_id.Map.t
- -> closures:Flambda.function_declarations Closure_id.Map.t
+ : sets_of_closures:(A.function_declarations Set_of_closures_id.Map.t)
-> values:descr Export_id.Map.t Compilation_unit.Map.t
-> symbol_id:Export_id.t Symbol.Map.t
-> offset_fun:int Closure_id.Map.t
-> offset_fv:int Var_within_closure.Map.t
- -> constant_sets_of_closures:Set_of_closures_id.Set.t
+ -> constant_closures:Closure_id.Set.t
-> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t
+ -> recursive:Variable.Set.t Set_of_closures_id.Map.t
-> t
+val create_transient
+ : sets_of_closures:(A.function_declarations Set_of_closures_id.Map.t)
+ -> values:descr Export_id.Map.t Compilation_unit.Map.t
+ -> symbol_id:Export_id.t Symbol.Map.t
+ -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t
+ -> recursive:Variable.Set.t Set_of_closures_id.Map.t
+ -> relevant_local_closure_ids: Closure_id.Set.t
+ -> relevant_imported_closure_ids : Closure_id.Set.t
+ -> relevant_local_vars_within_closure : Var_within_closure.Set.t
+ -> relevant_imported_vars_within_closure : Var_within_closure.Set.t
+ -> transient
+
(* CR-someday pchambart: Should we separate [t] in 2 types: one created by the
current [create] function, returned by [Build_export_info]. And
another built using t and offset_informations returned by
(** Record information about the layout of closures and which sets of
closures are constant. These are all worked out during the
[Flambda_to_clambda] pass. *)
-val add_clambda_info
- : t
- -> offset_fun:int Closure_id.Map.t
- -> offset_fv:int Var_within_closure.Map.t
- -> constant_sets_of_closures:Set_of_closures_id.Set.t
+val t_of_transient
+ : transient
+ -> program: Flambda.program
+ -> local_offset_fun:int Closure_id.Map.t
+ -> local_offset_fv:int Var_within_closure.Map.t
+ -> imported_offset_fun:int Closure_id.Map.t
+ -> imported_offset_fv:int Var_within_closure.Map.t
+ -> constant_closures:Closure_id.Set.t
-> t
(** Union of export information. Verifies that there are no identifier
(**/**)
(* Debug printing functions. *)
+val print_approx_components
+ : Format.formatter
+ -> symbol_id: Export_id.t Symbol.Map.t
+ -> values: descr Export_id.Map.t Compilation_unit.Map.t
+ -> Symbol.t list
+ -> unit
val print_approx : Format.formatter -> t * Symbol.t list -> unit
val print_functions : Format.formatter -> t -> unit
val print_offsets : Format.formatter -> t -> unit
val print_all : Format.formatter -> t * Symbol.t list -> unit
+
+(** Prints approx and descr as it is, without recursively looking up
+ [Export_id.t] *)
+val print_raw_approx : Format.formatter -> approx -> unit
+val print_raw_descr : Format.formatter -> descr -> unit
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+module A = Simple_value_approx
+
let rename_id_state = Export_id.Tbl.create 100
let rename_set_of_closures_id_state = Set_of_closures_id.Tbl.create 10
let imported_function_declarations_table =
(Set_of_closures_id.Tbl.create 10
- : Flambda.function_declarations Set_of_closures_id.Tbl.t)
+ : A.function_declarations Set_of_closures_id.Tbl.t)
(* Rename export identifiers' compilation units to denote that they now
live within a pack. *)
bound_vars =
Var_within_closure.Map.map (import_approx_for_pack units pack)
set_of_closures.bound_vars;
+ free_vars = set_of_closures.free_vars;
results =
Closure_id.Map.map (import_approx_for_pack units pack)
set_of_closures.results;
}
| Value_set_of_closures set_of_closures ->
Value_set_of_closures (import_set_of_closures units pack set_of_closures)
+ | Value_unknown_descr -> Value_unknown_descr
let rec import_code_for_pack units pack expr =
Flambda_iterators.map_named (function
~specialised_args:set_of_closures.specialised_args
~direct_call_surrogates:set_of_closures.direct_call_surrogates
~function_decls:
- (import_function_declarations_for_pack units pack
+ (import_function_declarations_for_pack_aux units pack
set_of_closures.function_decls)
in
Set_of_closures set_of_closures
and import_function_declarations_for_pack_aux units pack
(function_decls : Flambda.function_declarations) =
let funs =
- Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
+ Variable.Map.map
+ (fun (function_decl : Flambda.function_declaration) ->
Flambda.create_function_declaration ~params:function_decl.params
~body:(import_code_for_pack units pack function_decl.body)
~stub:function_decl.stub ~dbg:function_decl.dbg
~inline:function_decl.inline
~specialise:function_decl.specialise
- ~is_a_functor:function_decl.is_a_functor)
+ ~is_a_functor:function_decl.is_a_functor
+ ~closure_origin:function_decl.closure_origin)
function_decls.funs
in
Flambda.import_function_declarations_for_pack
(import_set_of_closures_id_for_pack units pack)
(import_set_of_closures_origin_for_pack units pack)
-and import_function_declarations_for_pack units pack
- (function_decls:Flambda.function_declarations) =
+let import_function_declarations_for_pack_aux units pack
+ (function_decls : A.function_declarations) : A.function_declarations =
+ let funs =
+ Variable.Map.map
+ (fun (function_decl : A.function_declaration) ->
+ A.update_function_declaration_body function_decl
+ (fun body -> import_code_for_pack units pack body))
+ function_decls.funs
+ in
+ A.import_function_declarations_for_pack
+ (A.update_function_declarations function_decls ~funs)
+ (import_set_of_closures_id_for_pack units pack)
+ (import_set_of_closures_origin_for_pack units pack)
+
+let import_function_declarations_approx_for_pack units pack
+ (function_decls: A.function_declarations) =
let original_set_of_closures_id = function_decls.set_of_closures_id in
try
Set_of_closures_id.Tbl.find imported_function_declarations_table
import_set_of_closures_id_for_pack pack_units pack
in
let import_function_declarations =
- import_function_declarations_for_pack pack_units pack
+ import_function_declarations_approx_for_pack pack_units pack
in
let sets_of_closures =
Set_of_closures_id.Map.map_keys import_set_of_closures_id
exp.sets_of_closures)
in
Export_info.create ~sets_of_closures
- ~closures:(Flambda_utils.make_closure_map' sets_of_closures)
~offset_fun:exp.offset_fun
~offset_fv:exp.offset_fv
~values:(import_eidmap import_descr exp.values)
~symbol_id:(Symbol.Map.map_keys import_sym
(Symbol.Map.map import_eid exp.symbol_id))
- ~constant_sets_of_closures:
- (Set_of_closures_id.Set.map import_set_of_closures_id
- exp.constant_sets_of_closures)
+ ~constant_closures:exp.constant_closures
~invariant_params:
(Set_of_closures_id.Map.map_keys import_set_of_closures_id
exp.invariant_params)
+ ~recursive:
+ (Set_of_closures_id.Map.map_keys import_set_of_closures_id
+ exp.recursive)
let clear_import_state () =
Set_of_closures_id.Tbl.clear imported_function_declarations_table;
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
-type for_one_or_more_units = {
+type 'a for_one_or_more_units = {
fun_offset_table : int Closure_id.Map.t;
fv_offset_table : int Var_within_closure.Map.t;
- closures : Flambda.function_declarations Closure_id.Map.t;
- constant_sets_of_closures : Set_of_closures_id.Set.t;
+ constant_closures : Closure_id.Set.t;
+ closures: Closure_id.Set.t;
}
type t = {
- current_unit : for_one_or_more_units;
- imported_units : for_one_or_more_units;
+ current_unit : Set_of_closures_id.t for_one_or_more_units;
+ imported_units : Simple_value_approx.function_declarations for_one_or_more_units;
}
-type ('a, 'b) declaration_position =
- | Current_unit of 'a
- | Imported_unit of 'b
- | Not_declared
-
let get_fun_offset t closure_id =
let fun_offset_table =
if Closure_id.in_compilation_unit closure_id (Compilenv.current_unit ())
- then t.current_unit.fun_offset_table
- else t.imported_units.fun_offset_table
+ then
+ t.current_unit.fun_offset_table
+ else
+ t.imported_units.fun_offset_table
in
try Closure_id.Map.find closure_id fun_offset_table
with Not_found ->
Misc.fatal_errorf "Flambda_to_clambda: missing offset for variable %a"
Var_within_closure.print var_within_closure
-let function_declaration_position t closure_id =
- try
- Current_unit (Closure_id.Map.find closure_id t.current_unit.closures)
- with Not_found ->
- try
- Imported_unit (Closure_id.Map.find closure_id t.imported_units.closures)
- with Not_found -> Not_declared
-
let is_function_constant t closure_id =
- match function_declaration_position t closure_id with
- | Current_unit { set_of_closures_id } ->
- Set_of_closures_id.Set.mem set_of_closures_id
- t.current_unit.constant_sets_of_closures
- | Imported_unit { set_of_closures_id } ->
- Set_of_closures_id.Set.mem set_of_closures_id
- t.imported_units.constant_sets_of_closures
- | Not_declared ->
+ if Closure_id.Set.mem closure_id t.current_unit.closures then
+ Closure_id.Set.mem closure_id t.current_unit.constant_closures
+ else if Closure_id.Set.mem closure_id t.imported_units.closures then
+ Closure_id.Set.mem closure_id t.imported_units.constant_closures
+ else
Misc.fatal_errorf "Flambda_to_clambda: missing closure %a"
Closure_id.print closure_id
let ident_for_var_exn t id = Variable.Map.find id t.var
let add_fresh_ident t var =
- let id = Ident.create (Variable.unique_name var) in
+ let id = Ident.create (Variable.name var) in
id, { t with var = Variable.Map.add var id t.var }
let ident_for_mutable_var_exn t mut_var =
Mutable_variable.Map.find mut_var t.mutable_var
let add_fresh_mutable_ident t mut_var =
- let id = Mutable_variable.unique_ident mut_var in
+ let id = Ident.create (Mutable_variable.name mut_var) in
let mutable_var = Mutable_variable.Map.add mut_var id t.mutable_var in
id, { t with mutable_var; }
if Numbers.Int.Set.cardinal num_keys = 0 then 0
else Numbers.Int.Set.max_elt num_keys + 1
in
- let index = Array.make num_keys 0 in
let store = Flambda_utils.Switch_storer.mk_store () in
- begin match default with
- | Some def when List.length cases < num_keys -> ignore (store.act_store def)
- | _ -> ()
+ let default_action =
+ match default with
+ | Some def when List.length cases < num_keys ->
+ store.act_store () def
+ | _ -> -1
+ in
+ let index = Array.make num_keys default_action in
+ let smallest_key = ref num_keys in
+ List.iter
+ (fun (key, lam) ->
+ index.(key) <- store.act_store () lam;
+ smallest_key := min key !smallest_key
+ )
+ cases;
+ if !smallest_key < num_keys then begin
+ let action = ref index.(!smallest_key) in
+ Array.iteri
+ (fun i act ->
+ if act >= 0 then action := act else index.(i) <- !action)
+ index
end;
- List.iter (fun (key, lam) -> index.(key) <- store.act_store lam) cases;
let actions = Array.map (to_clambda t env) (store.act_get ()) in
match actions with
| [| |] -> [| |], [| |] (* May happen when [default] is [None]. *)
let to_clambda_initialize_symbol t env symbol fields : Clambda.ulambda =
let fields =
- List.mapi (fun index expr -> index, to_clambda t env expr) fields
+ List.map (fun (index, expr) -> index, to_clambda t env expr) fields
in
let build_setfield (index, field) : Clambda.ulambda =
(* Note that this will never cause a write barrier hit, owing to
let to_clambda_program t env constants (program : Flambda.program) =
let rec loop env constants (program : Flambda.program_body)
- : Clambda.ulambda * Clambda.ustructured_constant Symbol.Map.t =
+ : Clambda.ulambda *
+ Clambda.ustructured_constant Symbol.Map.t *
+ Clambda.preallocated_block list =
match program with
| Let_symbol (symbol, alloc, program) ->
(* Useful only for unboxing. Since floats and boxed integers will
constants defs
in
loop env constants program
- | Initialize_symbol (symbol, _tag, fields, program) ->
- (* The tag is ignored here: It is used separately to generate the
- preallocated block. Only the initialisation code is generated
- here. *)
- let e1 = to_clambda_initialize_symbol t env symbol fields in
- let e2, constants = loop env constants program in
- Usequence (e1, e2), constants
+ | Initialize_symbol (symbol, tag, fields, program) ->
+ let fields =
+ List.mapi (fun i field ->
+ i, field,
+ Initialize_symbol_to_let_symbol.constant_field field)
+ fields
+ in
+ let init_fields =
+ Misc.Stdlib.List.filter_map (function
+ | (i, field, None) -> Some (i, field)
+ | (_, _, Some _) -> None)
+ fields
+ in
+ let constant_fields =
+ List.map (fun (_, _, constant_field) ->
+ match constant_field with
+ | None -> None
+ | Some (Flambda.Const const) ->
+ let n =
+ match const with
+ | Int i -> i
+ | Char c -> Char.code c
+ | Const_pointer i -> i
+ in
+ Some (Clambda.Uconst_field_int n)
+ | Some (Flambda.Symbol sym) ->
+ let lbl = Linkage_name.to_string (Symbol.label sym) in
+ Some (Clambda.Uconst_field_ref lbl))
+ fields
+ in
+ let e1 = to_clambda_initialize_symbol t env symbol init_fields in
+ let preallocated_block : Clambda.preallocated_block =
+ { symbol = Linkage_name.to_string (Symbol.label symbol);
+ exported = true;
+ tag = Tag.to_int tag;
+ fields = constant_fields;
+ }
+ in
+ let e2, constants, preallocated_blocks = loop env constants program in
+ Usequence (e1, e2), constants, preallocated_block :: preallocated_blocks
| Effect (expr, program) ->
let e1 = to_clambda t env expr in
- let e2, constants = loop env constants program in
- Usequence (e1, e2), constants
+ let e2, constants, preallocated_blocks = loop env constants program in
+ Usequence (e1, e2), constants, preallocated_blocks
| End _ ->
- Uconst (Uconst_ptr 0), constants
+ Uconst (Uconst_ptr 0), constants, []
in
loop env constants program.program_body
exported : Export_info.t;
}
-let convert (program, exported) : result =
+let convert (program, exported_transient) : result =
let current_unit =
+ let closures =
+ Closure_id.Map.keys (Flambda_utils.make_closure_map program)
+ in
+ let constant_closures =
+ Flambda_utils.all_lifted_constant_closures program
+ in
let offsets = Closure_offsets.compute program in
{ fun_offset_table = offsets.function_offsets;
fv_offset_table = offsets.free_variable_offsets;
- closures = Flambda_utils.make_closure_map program;
- constant_sets_of_closures =
- Flambda_utils.all_lifted_constant_sets_of_closures program;
+ constant_closures;
+ closures;
}
in
let imported_units =
let imported = Compilenv.approx_env () in
+ let closures =
+ Set_of_closures_id.Map.fold
+ (fun (_ : Set_of_closures_id.t) fun_decls acc ->
+ Variable.Map.fold
+ (fun var (_ : Simple_value_approx.function_declaration) acc ->
+ let closure_id = Closure_id.wrap var in
+ Closure_id.Set.add closure_id acc)
+ fun_decls.Simple_value_approx.funs
+ acc)
+ imported.sets_of_closures
+ Closure_id.Set.empty
+ in
{ fun_offset_table = imported.offset_fun;
fv_offset_table = imported.offset_fv;
- closures = imported.closures;
- constant_sets_of_closures = imported.constant_sets_of_closures;
+ constant_closures = imported.constant_closures;
+ closures;
}
in
let t = { current_unit; imported_units; } in
- let preallocated_blocks =
- List.map (fun (symbol, tag, fields) ->
- { Clambda.
- symbol = Linkage_name.to_string (Symbol.label symbol);
- exported = true;
- tag = Tag.to_int tag;
- size = List.length fields;
- })
- (Flambda_utils.initialize_symbols program)
- in
- let expr, structured_constants =
+ let expr, structured_constants, preallocated_blocks =
to_clambda_program t Env.empty Symbol.Map.empty program
in
- let offset_fun, offset_fv =
- Closure_offsets.compute_reexported_offsets program
- ~current_unit_offset_fun:current_unit.fun_offset_table
- ~current_unit_offset_fv:current_unit.fv_offset_table
- ~imported_units_offset_fun:imported_units.fun_offset_table
- ~imported_units_offset_fv:imported_units.fv_offset_table
- in
let exported =
- Export_info.add_clambda_info exported
- ~offset_fun
- ~offset_fv
- ~constant_sets_of_closures:current_unit.constant_sets_of_closures
+ Export_info.t_of_transient exported_transient
+ ~program
+ ~local_offset_fun:current_unit.fun_offset_table
+ ~local_offset_fv:current_unit.fv_offset_table
+ ~imported_offset_fun:imported_units.fun_offset_table
+ ~imported_offset_fv:imported_units.fv_offset_table
+ ~constant_closures:current_unit.constant_closures
in
{ expr; preallocated_blocks; structured_constants; exported; }
For direct calls, the hidden closure parameter is added. Switch
tables are also built.
*)
-val convert : Flambda.program * Export_info.t -> result
+val convert : Flambda.program * Export_info.transient -> result
(* Emit the code for a floating-point comparison *)
-let emit_float_test cmp neg arg lbl =
+let emit_float_test cmp arg lbl =
let actual_cmp =
match (is_tos arg.(0), is_tos arg.(1)) with
| (true, true) ->
| (false, true) ->
(* second arg on top of FP stack *)
I.fcomp (reg arg.(0));
- Cmm.swap_comparison cmp
+ Cmm.swap_float_comparison cmp
| (false, false) ->
I.fld (reg arg.(0));
I.fcomp (reg arg.(1));
in
I.fnstsw ax;
match actual_cmp with
- | Ceq ->
- if neg then begin
- I.and_ (int 68) ah;
- I.xor (int 64) ah;
- I.jne lbl
- end else begin
- I.and_ (int 69) ah;
- I.cmp (int 64) ah;
- I.je lbl
- end
- | Cne ->
- if neg then begin
- I.and_ (int 69) ah;
- I.cmp (int 64) ah;
- I.je lbl
- end else begin
- I.and_ (int 68) ah;
- I.xor (int 64) ah;
- I.jne lbl
- end
- | Cle ->
+ | CFeq ->
+ I.and_ (int 69) ah;
+ I.cmp (int 64) ah;
+ I.je lbl
+ | CFneq ->
+ I.and_ (int 68) ah;
+ I.xor (int 64) ah;
+ I.jne lbl
+ | CFle ->
I.and_ (int 69) ah;
I.dec ah;
I.cmp (int 64) ah;
- if neg
- then I.jae lbl
- else I.jb lbl
- | Cge ->
+ I.jb lbl
+ | CFnle ->
+ I.and_ (int 69) ah;
+ I.dec ah;
+ I.cmp (int 64) ah;
+ I.jae lbl
+ | CFge ->
+ I.and_ (int 5) ah;
+ I.je lbl
+ | CFnge ->
I.and_ (int 5) ah;
- if neg
- then I.jne lbl
- else I.je lbl
- | Clt ->
+ I.jne lbl
+ | CFlt ->
I.and_ (int 69) ah;
I.cmp (int 1) ah;
- if neg
- then I.jne lbl
- else I.je lbl
- | Cgt ->
+ I.je lbl
+ | CFnlt ->
+ I.and_ (int 69) ah;
+ I.cmp (int 1) ah;
+ I.jne lbl
+ | CFgt ->
+ I.and_ (int 69) ah;
+ I.je lbl
+ | CFngt ->
I.and_ (int 69) ah;
- if neg
- then I.jne lbl
- else I.je lbl
+ I.jne lbl
(* Emit a Ifloatspecial instruction *)
| Iinttest_imm(cmp, n) ->
I.cmp (int n) (reg i.arg.(0));
I.j (cond cmp) lbl
- | Ifloattest(cmp, neg) ->
- emit_float_test cmp neg i.arg lbl
+ | Ifloattest cmp ->
+ emit_float_test cmp i.arg lbl
| Ioddtest ->
I.test (int 1) (reg i.arg.(0));
I.jne lbl
| Iop(Ialloc _ | Iintop Imulh) -> [| eax |]
| Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |]
| Iop(Iintoffloat) -> [| eax |]
- | Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |]
+ | Iifthenelse(Ifloattest _, _, _) -> [| eax |]
| _ -> [||]
let destroyed_at_raise = all_phys_regs
module A = Simple_value_approx
let import_set_of_closures =
- let import_function_declarations (clos : Flambda.function_declarations)
- : Flambda.function_declarations =
+ let import_function_declarations (clos : A.function_declarations)
+ : A.function_declarations =
(* CR-soon mshinwell for pchambart: Do we still need to do this
rewriting? I'm wondering if maybe we don't have to any more. *)
- let sym_to_fun_var_map (clos : Flambda.function_declarations) =
+ let sym_to_fun_var_map (clos : A.function_declarations) =
Variable.Map.fold (fun fun_var _ acc ->
let closure_id = Closure_id.wrap fun_var in
let sym = Compilenv.closure_symbol closure_id in
| named -> named
in
let funs =
- Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
- let body =
- Flambda_iterators.map_toplevel_named f_named function_decl.body
- in
- Flambda.create_function_declaration ~params:function_decl.params
- ~body ~stub:function_decl.stub ~dbg:function_decl.dbg
- ~inline:function_decl.inline
- ~specialise:function_decl.specialise
- ~is_a_functor:function_decl.is_a_functor)
+ Variable.Map.map (fun (function_decl : A.function_declaration) ->
+ A.update_function_declaration_body function_decl
+ (Flambda_iterators.map_toplevel_named f_named))
clos.funs
in
- Flambda.update_function_declarations clos ~funs
+ A.update_function_declarations clos ~funs
in
let aux set_of_closures_id =
- ignore (Compilenv.approx_for_global
- (Set_of_closures_id.get_compilation_unit set_of_closures_id));
- let ex_info = Compilenv.approx_env () in
- let function_declarations =
+ match
+ Compilenv.approx_for_global
+ (Set_of_closures_id.get_compilation_unit set_of_closures_id)
+ with
+ | None -> None
+ | Some ex_info ->
try
- Some (Set_of_closures_id.Map.find set_of_closures_id
- ex_info.sets_of_closures)
+ let function_declarations =
+ Set_of_closures_id.Map.find set_of_closures_id
+ ex_info.sets_of_closures
+ in
+ Some (import_function_declarations function_declarations)
with Not_found ->
- None
- in
- match function_declarations with
- | None -> None
- | Some function_declarations ->
- Some (import_function_declarations function_declarations)
+ Misc.fatal_error "Cannot find set of closures"
in
Set_of_closures_id.Tbl.memoize Compilenv.imported_sets_of_closures_table aux
let rec import_ex ex =
- ignore (Compilenv.approx_for_global (Export_id.get_compilation_unit ex));
- let ex_info = Compilenv.approx_env () in
- let import_value_set_of_closures ~set_of_closures_id ~bound_vars
+ let import_value_set_of_closures ~set_of_closures_id ~bound_vars ~free_vars
~(ex_info : Export_info.t) ~what : A.value_set_of_closures option =
let bound_vars = Var_within_closure.Map.map import_approx bound_vars in
- match
- Set_of_closures_id.Map.find set_of_closures_id ex_info.invariant_params
- with
- | exception Not_found ->
- Misc.fatal_errorf "Set of closures ID %a not found in invariant_params \
- (when importing [%a: %s])"
- Set_of_closures_id.print set_of_closures_id
- Export_id.print ex
- what
- | invariant_params ->
- match import_set_of_closures set_of_closures_id with
- | None -> None
- | Some function_decls ->
- Some (A.create_value_set_of_closures
- ~function_decls
- ~bound_vars
- ~invariant_params:(lazy invariant_params)
- ~specialised_args:Variable.Map.empty
- ~freshening:Freshening.Project_var.empty
- ~direct_call_surrogates:Closure_id.Map.empty)
+ match import_set_of_closures set_of_closures_id with
+ | None -> None
+ | Some function_decls ->
+ (* CR-someday xclerc: add a test to the test suite to ensure that
+ classic mode behaves as expected. *)
+ let is_classic_mode = function_decls.is_classic_mode in
+ let invariant_params =
+ match
+ Set_of_closures_id.Map.find set_of_closures_id
+ ex_info.invariant_params
+ with
+ | exception Not_found ->
+ if is_classic_mode then
+ Variable.Map.empty
+ else
+ Misc.fatal_errorf "Set of closures ID %a not found in \
+ invariant_params (when importing [%a: %s])"
+ Set_of_closures_id.print set_of_closures_id
+ Export_id.print ex
+ what
+ | found -> found
+ in
+ let recursive =
+ match
+ Set_of_closures_id.Map.find set_of_closures_id ex_info.recursive
+ with
+ | exception Not_found ->
+ if is_classic_mode then
+ Variable.Set.empty
+ else
+ Misc.fatal_errorf "Set of closures ID %a not found in \
+ recursive (when importing [%a: %s])"
+ Set_of_closures_id.print set_of_closures_id
+ Export_id.print ex
+ what
+ | found -> found
+ in
+ Some (A.create_value_set_of_closures
+ ~function_decls
+ ~bound_vars
+ ~free_vars
+ ~invariant_params:(lazy invariant_params)
+ ~recursive:(lazy recursive)
+ ~specialised_args:Variable.Map.empty
+ ~freshening:Freshening.Project_var.empty
+ ~direct_call_surrogates:Closure_id.Map.empty)
in
- match Export_info.find_description ex_info ex with
- | exception Not_found -> A.value_unknown Other
- | Value_int i -> A.value_int i
- | Value_char c -> A.value_char c
- | Value_constptr i -> A.value_constptr i
- | Value_float f -> A.value_float f
- | Value_float_array float_array ->
- begin match float_array.contents with
- | Unknown_or_mutable ->
- A.value_mutable_float_array ~size:float_array.size
- | Contents contents ->
- A.value_immutable_float_array
- (Array.map (function
- | None -> A.value_any_float
- | Some f -> A.value_float f)
- contents)
- end
- | Export_info.Value_boxed_int (t, i) -> A.value_boxed_int t i
- | Value_string { size; contents } ->
- let contents =
- match contents with
- | Unknown_or_mutable -> None
- | Contents contents -> Some contents
- in
- A.value_string size contents
- | Value_mutable_block _ -> A.value_unknown Other
- | Value_block (tag, fields) ->
- A.value_block tag (Array.map import_approx fields)
- | Value_closure { closure_id;
- set_of_closures =
- { set_of_closures_id; bound_vars; aliased_symbol } } ->
- let value_set_of_closures =
- import_value_set_of_closures ~set_of_closures_id ~bound_vars ~ex_info
- ~what:(Format.asprintf "Value_closure %a" Closure_id.print closure_id)
- in
- begin match value_set_of_closures with
- | None -> A.value_unresolved (Set_of_closures_id set_of_closures_id)
- | Some value_set_of_closures ->
- A.value_closure ?set_of_closures_symbol:aliased_symbol
- value_set_of_closures closure_id
- end
- | Value_set_of_closures { set_of_closures_id; bound_vars; aliased_symbol } ->
- let value_set_of_closures =
- import_value_set_of_closures ~set_of_closures_id ~bound_vars ~ex_info
- ~what:"Value_set_of_closures"
- in
- match value_set_of_closures with
- | None ->
- A.value_unresolved (Set_of_closures_id set_of_closures_id)
- | Some value_set_of_closures ->
- let approx = A.value_set_of_closures value_set_of_closures in
- match aliased_symbol with
- | None -> approx
- | Some symbol -> A.augment_with_symbol approx symbol
+ let compilation_unit = Export_id.get_compilation_unit ex in
+ match Compilenv.approx_for_global compilation_unit with
+ | None -> A.value_unknown Other
+ | Some ex_info ->
+ match Export_info.find_description ex_info ex with
+ | exception Not_found ->
+ Misc.fatal_errorf "Cannot find export id %a" Export_id.print ex
+ | Value_unknown_descr -> A.value_unknown Other
+ | Value_int i -> A.value_int i
+ | Value_char c -> A.value_char c
+ | Value_constptr i -> A.value_constptr i
+ | Value_float f -> A.value_float f
+ | Value_float_array float_array ->
+ begin match float_array.contents with
+ | Unknown_or_mutable ->
+ A.value_mutable_float_array ~size:float_array.size
+ | Contents contents ->
+ A.value_immutable_float_array
+ (Array.map (function
+ | None -> A.value_any_float
+ | Some f -> A.value_float f)
+ contents)
+ end
+ | Export_info.Value_boxed_int (t, i) -> A.value_boxed_int t i
+ | Value_string { size; contents } ->
+ let contents =
+ match contents with
+ | Unknown_or_mutable -> None
+ | Contents contents -> Some contents
+ in
+ A.value_string size contents
+ | Value_mutable_block _ -> A.value_unknown Other
+ | Value_block (tag, fields) ->
+ A.value_block tag (Array.map import_approx fields)
+ | Value_closure { closure_id;
+ set_of_closures =
+ { set_of_closures_id; bound_vars; free_vars; aliased_symbol } } ->
+ let value_set_of_closures =
+ import_value_set_of_closures
+ ~set_of_closures_id ~bound_vars ~free_vars ~ex_info
+ ~what:(Format.asprintf "Value_closure %a" Closure_id.print closure_id)
+ in
+ begin match value_set_of_closures with
+ | None -> A.value_unresolved (Set_of_closures_id set_of_closures_id)
+ | Some value_set_of_closures ->
+ A.value_closure ?set_of_closures_symbol:aliased_symbol
+ value_set_of_closures closure_id
+ end
+ | Value_set_of_closures
+ { set_of_closures_id; bound_vars; free_vars; aliased_symbol } ->
+ let value_set_of_closures =
+ import_value_set_of_closures ~set_of_closures_id
+ ~bound_vars ~free_vars ~ex_info ~what:"Value_set_of_closures"
+ in
+ match value_set_of_closures with
+ | None ->
+ A.value_unresolved (Set_of_closures_id set_of_closures_id)
+ | Some value_set_of_closures ->
+ let approx = A.value_set_of_closures value_set_of_closures in
+ match aliased_symbol with
+ | None -> approx
+ | Some symbol -> A.augment_with_symbol approx symbol
and import_approx (ap : Export_info.approx) =
match ap with
let import_symbol sym =
if Compilenv.is_predefined_exception sym then
A.value_unknown Other
- else
- let symbol_id_map =
- let global = Symbol.compilation_unit sym in
- (Compilenv.approx_for_global global).symbol_id
- in
- match Symbol.Map.find sym symbol_id_map with
- | approx -> A.augment_with_symbol (import_ex approx) sym
- | exception Not_found ->
- A.value_unresolved (Symbol sym)
+ else begin
+ let compilation_unit = Symbol.compilation_unit sym in
+ match Compilenv.approx_for_global compilation_unit with
+ | None -> A.value_unresolved (Symbol sym)
+ | Some export_info ->
+ match Symbol.Map.find sym export_info.symbol_id with
+ | approx -> A.augment_with_symbol (import_ex approx) sym
+ | exception Not_found ->
+ Misc.fatal_errorf
+ "Compilation unit = %a Cannot find symbol %a"
+ Compilation_unit.print compilation_unit
+ Symbol.print sym
+ end
(* Note for code reviewers: Observe that [really_import] iterates until
the approximation description is fully resolved (or a necessary .cmx
(* Invert a test *)
let invert_integer_test = function
- Isigned cmp -> Isigned(Cmm.negate_comparison cmp)
- | Iunsigned cmp -> Iunsigned(Cmm.negate_comparison cmp)
+ Isigned cmp -> Isigned(Cmm.negate_integer_comparison cmp)
+ | Iunsigned cmp -> Iunsigned(Cmm.negate_integer_comparison cmp)
let invert_test = function
Itruetest -> Ifalsetest
| Ifalsetest -> Itruetest
| Iinttest(cmp) -> Iinttest(invert_integer_test cmp)
| Iinttest_imm(cmp, n) -> Iinttest_imm(invert_integer_test cmp, n)
- | Ifloattest(cmp, neg) -> Ifloattest(cmp, not neg)
+ | Ifloattest(cmp) -> Ifloattest(Cmm.negate_float_comparison cmp)
| Ieventest -> Ioddtest
| Ioddtest -> Ieventest
let fundecl f =
{ fun_name = f.Mach.fun_name;
fun_body = linear f.Mach.fun_body end_instr;
- fun_fast = f.Mach.fun_fast;
+ fun_fast = not (List.mem Cmm.Reduce_code_size f.Mach.fun_codegen_options);
fun_dbg = f.Mach.fun_dbg;
fun_spacetime_shape = f.Mach.fun_spacetime_shape;
}
type label = Cmm.label
type integer_comparison =
- Isigned of Cmm.comparison
- | Iunsigned of Cmm.comparison
+ Isigned of Cmm.integer_comparison
+ | Iunsigned of Cmm.integer_comparison
type integer_operation =
Iadd | Isub | Imul | Imulh | Idiv | Imod
| Icheckbound of { label_after_error : label option;
spacetime_index : int; }
+type float_comparison = Cmm.float_comparison
+
type test =
Itruetest
| Ifalsetest
| Iinttest of integer_comparison
| Iinttest_imm of integer_comparison * int
- | Ifloattest of Cmm.comparison * bool
+ | Ifloattest of float_comparison
| Ioddtest
| Ieventest
{ fun_name: string;
fun_args: Reg.t array;
fun_body: instruction;
- fun_fast: bool;
+ fun_codegen_options : Cmm.codegen_option list;
fun_dbg : Debuginfo.t;
fun_spacetime_shape : spacetime_shape option;
}
type label = Cmm.label
type integer_comparison =
- Isigned of Cmm.comparison
- | Iunsigned of Cmm.comparison
+ Isigned of Cmm.integer_comparison
+ | Iunsigned of Cmm.integer_comparison
type integer_operation =
Iadd | Isub | Imul | Imulh | Idiv | Imod
second being the pointer to the trie node for the current function
(and the first being as per non-Spacetime mode). *)
+type float_comparison = Cmm.float_comparison
+
type test =
Itruetest
| Ifalsetest
| Iinttest of integer_comparison
| Iinttest_imm of integer_comparison * int
- | Ifloattest of Cmm.comparison * bool
+ | Ifloattest of float_comparison
| Ioddtest
| Ieventest
{ fun_name: string;
fun_args: Reg.t array;
fun_body: instruction;
- fun_fast: bool;
+ fun_codegen_options : Cmm.codegen_option list;
fun_dbg : Debuginfo.t;
fun_spacetime_shape : spacetime_shape option;
}
let (comp, branch) = name_for_int_comparison cmp in
` {emit_string comp}i {emit_reg i.arg.(0)}, {emit_int n}\n`;
` {emit_string branch} {emit_label lbl}\n`
- | Ifloattest(cmp, neg) ->
+ | Ifloattest cmp -> begin
` fcmpu 0, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
(* bit 0 = lt, bit 1 = gt, bit 2 = eq *)
- let (bitnum, negtst) =
+ let bitnum =
match cmp with
- Ceq -> (2, neg)
- | Cne -> (2, not neg)
- | Cle -> ` cror 3, 0, 2\n`; (* lt or eq *)
- (3, neg)
- | Cgt -> (1, neg)
- | Cge -> ` cror 3, 1, 2\n`; (* gt or eq *)
- (3, neg)
- | Clt -> (0, neg) in
- if negtst
- then ` bf {emit_int bitnum}, {emit_label lbl}\n`
- else ` bt {emit_int bitnum}, {emit_label lbl}\n`
+ | CFeq | CFneq -> 2
+ | CFle | CFnle ->
+ ` cror 3, 0, 2\n`; (* lt or eq *)
+ 3
+ | CFgt | CFngt -> 1
+ | CFge | CFnge ->
+ ` cror 3, 1, 2\n`; (* gt or eq *)
+ 3
+ | CFlt | CFnlt -> 0
+ in
+ match cmp with
+ | CFneq | CFngt | CFnge | CFnlt | CFnle ->
+ ` bf {emit_int bitnum}, {emit_label lbl}\n`
+ | CFeq | CFgt | CFge | CFlt | CFle ->
+ ` bt {emit_int bitnum}, {emit_label lbl}\n`
+ end
| Ioddtest ->
` andi. 0, {emit_reg i.arg.(0)}, 1\n`;
` bne {emit_label lbl}\n`
fprintf ppf "*%a" machtype_component mty.(i)
done
-let comparison = function
+let integer_comparison = function
| Ceq -> "=="
| Cne -> "!="
| Clt -> "<"
| Cgt -> ">"
| Cge -> ">="
+let float_comparison = function
+ | CFeq -> "=="
+ | CFneq -> "!="
+ | CFlt -> "<"
+ | CFnlt -> "!<"
+ | CFle -> "<="
+ | CFnle -> "!<="
+ | CFgt -> ">"
+ | CFngt -> "!>"
+ | CFge -> ">="
+ | CFnge -> "!>="
+
let chunk = function
| Byte_unsigned -> "unsigned int8"
| Byte_signed -> "signed int8"
| Clsl -> "<<"
| Clsr -> ">>u"
| Casr -> ">>s"
- | Ccmpi c -> comparison c
+ | Ccmpi c -> integer_comparison c
| Caddv -> "+v"
| Cadda -> "+a"
- | Ccmpa c -> Printf.sprintf "%sa" (comparison c)
+ | Ccmpa c -> Printf.sprintf "%sa" (integer_comparison c)
| Cnegf -> "~f"
| Cabsf -> "absf"
| Caddf -> "+f"
| Cdivf -> "/f"
| Cfloatofint -> "floatofint"
| Cintoffloat -> "intoffloat"
- | Ccmpf c -> Printf.sprintf "%sf" (comparison c)
+ | Ccmpf c -> Printf.sprintf "%sf" (float_comparison c)
| Craise k -> Format.asprintf "%a%s" raise_kind k (Debuginfo.to_string d)
| Ccheckbound -> "checkbound" ^ Debuginfo.to_string d
val rec_flag : formatter -> Cmm.rec_flag -> unit
val machtype_component : formatter -> Cmm.machtype_component -> unit
val machtype : formatter -> Cmm.machtype_component array -> unit
-val comparison : Cmm.comparison -> string
+val integer_comparison : Cmm.integer_comparison -> string
+val float_comparison : Cmm.float_comparison -> string
val chunk : Cmm.memory_chunk -> string
val operation : Debuginfo.t -> Cmm.operation -> string
val expression : formatter -> Cmm.expression -> unit
s
let intcomp = function
- | Isigned c -> Printf.sprintf " %ss " (Printcmm.comparison c)
- | Iunsigned c -> Printf.sprintf " %su " (Printcmm.comparison c)
+ | Isigned c -> Printf.sprintf " %ss " (Printcmm.integer_comparison c)
+ | Iunsigned c -> Printf.sprintf " %su " (Printcmm.integer_comparison c)
let floatcomp c =
- Printf.sprintf " %sf " (Printcmm.comparison c)
+ Printf.sprintf " %sf " (Printcmm.float_comparison c)
let intop = function
| Iadd -> " + "
| Ifalsetest -> fprintf ppf "not %a" reg arg.(0)
| Iinttest cmp -> fprintf ppf "%a%s%a" reg arg.(0) (intcomp cmp) reg arg.(1)
| Iinttest_imm(cmp, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intcomp cmp) n
- | Ifloattest(cmp, neg) ->
- fprintf ppf "%s%a%s%a"
- (if neg then "not " else "")
+ | Ifloattest cmp ->
+ fprintf ppf "%a%s%a"
reg arg.(0) (floatcomp cmp) reg arg.(1)
| Ieventest -> fprintf ppf "%a & 1 == 0" reg arg.(0)
| Ioddtest -> fprintf ppf "%a & 1 == 1" reg arg.(0)
redo_regalloc <- false;
let new_body = self#reload f.fun_body in
({fun_name = f.fun_name; fun_args = f.fun_args;
- fun_body = new_body; fun_fast = f.fun_fast;
+ fun_body = new_body; fun_codegen_options = f.fun_codegen_options;
fun_dbg = f.fun_dbg; fun_spacetime_shape = f.fun_spacetime_shape},
redo_regalloc)
end
(* Masks for conditional branches after comparisons *)
+(* bit 0 = eq, bit 1 = lt, bit 2 = gt, bit 3 = overflow*)
let branch_for_comparison = function
- Ceq -> 8 | Cne -> 7
- | Cle -> 12 | Cgt -> 2
- | Cge -> 10 | Clt -> 4
+ | Ceq -> 0b1000 | Cne -> 0b0111 (* BRNEL is 0111 rather than 0110 *)
+ | Cle -> 0b1100 | Cgt -> 0b0010
+ | Cge -> 0b1010 | Clt -> 0b0100
let name_for_int_comparison = function
Isigned cmp -> ("cgr", branch_for_comparison cmp)
| Iunsigned cmp -> ("clgfi", branch_for_comparison cmp)
(* bit 0 = eq, bit 1 = lt, bit 2 = gt, bit 3 = unordered*)
-let branch_for_float_comparison cmp neg =
- match cmp with
- Ceq -> if neg then 7 else 8
- | Cne -> if neg then 8 else 7
- | Cle -> if neg then 3 else 12
- | Cgt -> if neg then 13 else 2
- | Cge -> if neg then 5 else 10
- | Clt -> if neg then 11 else 4
+let branch_for_float_comparison = function
+ | CFeq -> 0b1000
+ | CFneq -> 0b0111
+
+ | CFle -> 0b1100
+ | CFnle -> 0b0011
+
+ | CFgt -> 0b0010
+ | CFngt -> 0b1101
+
+ | CFge -> 0b1010
+ | CFnge -> 0b0101
+
+ | CFlt -> 0b0100
+ | CFnlt -> 0b1011
(* Names for various instructions *)
let (comp, mask) = name_for_int_comparison_imm cmp in
` {emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}\n`;
` brcl {emit_int mask}, {emit_label lbl}\n`
- | Ifloattest(cmp, neg) ->
+ | Ifloattest cmp ->
` cdbr {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
- let mask = branch_for_float_comparison cmp neg in
+ let mask = branch_for_float_comparison cmp in
` brcl {emit_int mask}, {emit_label lbl}\n`
| Ioddtest ->
` tmll {emit_reg i.arg.(0)}, 1\n`;
(* Swap the two arguments of an integer comparison *)
let swap_intcomp = function
- Isigned cmp -> Isigned(swap_comparison cmp)
- | Iunsigned cmp -> Iunsigned(swap_comparison cmp)
+ Isigned cmp -> Isigned(swap_integer_comparison cmp)
+ | Iunsigned cmp -> Iunsigned(swap_integer_comparison cmp)
(* Naming of registers *)
Cop(Ccmpi cmp, [arg1; Cconst_int n], _) when self#is_immediate n ->
(Iinttest_imm(Isigned cmp, n), arg1)
| Cop(Ccmpi cmp, [Cconst_int n; arg2], _) when self#is_immediate n ->
- (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2)
+ (Iinttest_imm(Isigned(swap_integer_comparison cmp), n), arg2)
| Cop(Ccmpi cmp, [arg1; Cconst_pointer n], _) when self#is_immediate n ->
(Iinttest_imm(Isigned cmp, n), arg1)
| Cop(Ccmpi cmp, [Cconst_pointer n; arg2], _) when self#is_immediate n ->
- (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2)
+ (Iinttest_imm(Isigned(swap_integer_comparison cmp), n), arg2)
| Cop(Ccmpi cmp, args, _) ->
(Iinttest(Isigned cmp), Ctuple args)
| Cop(Ccmpa cmp, [arg1; Cconst_pointer n], _) when self#is_immediate n ->
| Cop(Ccmpa cmp, [arg1; Cconst_int n], _) when self#is_immediate n ->
(Iinttest_imm(Iunsigned cmp, n), arg1)
| Cop(Ccmpa cmp, [Cconst_pointer n; arg2], _) when self#is_immediate n ->
- (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2)
+ (Iinttest_imm(Iunsigned(swap_integer_comparison cmp), n), arg2)
| Cop(Ccmpa cmp, [Cconst_int n; arg2], _) when self#is_immediate n ->
- (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2)
+ (Iinttest_imm(Iunsigned(swap_integer_comparison cmp), n), arg2)
| Cop(Ccmpa cmp, args, _) ->
(Iinttest(Iunsigned cmp), Ctuple args)
| Cop(Ccmpf cmp, args, _) ->
- (Ifloattest(cmp, false), Ctuple args)
+ (Ifloattest cmp, Ctuple args)
| Cop(Cand, [arg; Cconst_int 1], _) ->
(Ioddtest, arg)
| arg ->
{ fun_name = f.Cmm.fun_name;
fun_args = loc_arg;
fun_body = body;
- fun_fast = f.Cmm.fun_fast;
+ fun_codegen_options = f.Cmm.fun_codegen_options;
fun_dbg = f.Cmm.fun_dbg;
fun_spacetime_shape;
}
{ fun_name = f.fun_name;
fun_args = f.fun_args;
fun_body = new_body;
- fun_fast = f.fun_fast;
+ fun_codegen_options = f.fun_codegen_options;
fun_dbg = f.fun_dbg;
fun_spacetime_shape = f.fun_spacetime_shape;
}
{ fun_name = f.fun_name;
fun_args = new_args;
fun_body = new_body;
- fun_fast = f.fun_fast;
+ fun_codegen_options = f.fun_codegen_options;
fun_dbg = f.fun_dbg;
fun_spacetime_shape = f.fun_spacetime_shape;
}
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Fu Yong Quah, Jane Street Europe *)
+(* *)
+(* Copyright 2017 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+module A = Simple_value_approx
+
+type queue_elem =
+ | Q_symbol of Symbol.t
+ | Q_set_of_closures_id of Set_of_closures_id.t
+ | Q_export_id of Export_id.t
+
+type symbols_to_export =
+ { symbols : Symbol.Set.t;
+ export_ids : Export_id.Set.t;
+ set_of_closure_ids : Set_of_closures_id.Set.t;
+ set_of_closure_ids_keep_declaration : Set_of_closures_id.Set.t;
+ relevant_imported_closure_ids : Closure_id.Set.t;
+ relevant_local_closure_ids : Closure_id.Set.t;
+ relevant_imported_vars_within_closure : Var_within_closure.Set.t;
+ relevant_local_vars_within_closure : Var_within_closure.Set.t;
+ }
+
+let traverse
+ ~(sets_of_closures_map :
+ Flambda.set_of_closures Set_of_closures_id.Map.t)
+ ~(closure_id_to_set_of_closures_id :
+ Set_of_closures_id.t Closure_id.Map.t)
+ ~(function_declarations_map :
+ A.function_declarations Set_of_closures_id.Map.t)
+ ~(values : Export_info.descr Export_id.Map.t)
+ ~(symbol_id : Export_id.t Symbol.Map.t)
+ ~(root_symbol: Symbol.t) =
+ let relevant_set_of_closures_declaration_only =
+ ref Set_of_closures_id.Set.empty
+ in
+ let relevant_symbols = ref (Symbol.Set.singleton root_symbol) in
+ let relevant_set_of_closures = ref Set_of_closures_id.Set.empty in
+ let relevant_export_ids = ref Export_id.Set.empty in
+ let relevant_imported_closure_ids = ref Closure_id.Set.empty in
+ let relevant_local_closure_ids = ref Closure_id.Set.empty in
+ let relevant_imported_vars_within_closure =
+ ref Var_within_closure.Set.empty
+ in
+ let relevant_local_vars_with_closure = ref Var_within_closure.Set.empty in
+ let (queue : queue_elem Queue.t) = Queue.create () in
+ let conditionally_add_symbol symbol =
+ if not (Symbol.Set.mem symbol !relevant_symbols) then begin
+ relevant_symbols :=
+ Symbol.Set.add symbol !relevant_symbols;
+ Queue.add (Q_symbol symbol) queue
+ end
+ in
+ let conditionally_add_set_of_closures_id set_of_closures_id =
+ if not (Set_of_closures_id.Set.mem
+ set_of_closures_id !relevant_set_of_closures) then begin
+ relevant_set_of_closures :=
+ Set_of_closures_id.Set.add set_of_closures_id
+ !relevant_set_of_closures;
+ Queue.add (Q_set_of_closures_id set_of_closures_id) queue
+ end
+ in
+ let conditionally_add_export_id export_id =
+ if not (Export_id.Set.mem export_id !relevant_export_ids) then begin
+ relevant_export_ids :=
+ Export_id.Set.add export_id !relevant_export_ids;
+ Queue.add (Q_export_id export_id) queue
+ end
+ in
+ let process_approx (approx : Export_info.approx) =
+ match approx with
+ | Value_id export_id ->
+ conditionally_add_export_id export_id
+ | Value_symbol symbol ->
+ conditionally_add_symbol symbol
+ | Value_unknown -> ()
+ in
+ let process_value_set_of_closures
+ (soc : Export_info.value_set_of_closures) =
+ conditionally_add_set_of_closures_id soc.set_of_closures_id;
+ Var_within_closure.Map.iter
+ (fun _ value -> process_approx value) soc.bound_vars;
+ Closure_id.Map.iter
+ (fun _ value -> process_approx value) soc.results;
+ begin match soc.aliased_symbol with
+ | None -> ()
+ | Some symbol -> conditionally_add_symbol symbol
+ end
+ in
+ let process_function_body (function_body : A.function_body) =
+ Flambda_iterators.iter
+ (fun (term : Flambda.t) ->
+ match term with
+ | Flambda.Apply { kind ; _ } ->
+ begin match kind with
+ | Indirect -> ()
+ | Direct closure_id ->
+ begin match
+ Closure_id.Map.find
+ closure_id
+ closure_id_to_set_of_closures_id
+ with
+ | exception Not_found ->
+ relevant_imported_closure_ids :=
+ Closure_id.Set.add closure_id
+ !relevant_imported_closure_ids
+ | set_of_closures_id ->
+ relevant_local_closure_ids :=
+ Closure_id.Set.add closure_id
+ !relevant_local_closure_ids;
+ conditionally_add_set_of_closures_id
+ set_of_closures_id
+ end
+ end
+ | _ -> ())
+ (fun (named : Flambda.named) ->
+ let process_closure_id closure_id =
+ match
+ Closure_id.Map.find closure_id closure_id_to_set_of_closures_id
+ with
+ | exception Not_found ->
+ relevant_imported_closure_ids :=
+ Closure_id.Set.add closure_id !relevant_imported_closure_ids
+ | set_of_closure_id ->
+ relevant_local_closure_ids :=
+ Closure_id.Set.add closure_id !relevant_local_closure_ids;
+ relevant_set_of_closures_declaration_only :=
+ Set_of_closures_id.Set.add
+ set_of_closure_id
+ !relevant_set_of_closures_declaration_only
+ in
+ match named with
+ | Symbol symbol
+ | Read_symbol_field (symbol, _) ->
+ conditionally_add_symbol symbol
+ | Set_of_closures soc ->
+ conditionally_add_set_of_closures_id
+ soc.function_decls.set_of_closures_id
+ | Project_closure { closure_id; _ } ->
+ process_closure_id closure_id
+ | Move_within_set_of_closures { start_from; move_to; _ } ->
+ process_closure_id start_from;
+ process_closure_id move_to
+ | Project_var { closure_id ; var; _ } ->
+ begin match
+ Closure_id.Map.find
+ closure_id closure_id_to_set_of_closures_id
+ with
+ | exception Not_found ->
+ relevant_imported_closure_ids :=
+ Closure_id.Set.add closure_id
+ !relevant_imported_closure_ids;
+ relevant_imported_vars_within_closure :=
+ Var_within_closure.Set.add var
+ !relevant_imported_vars_within_closure
+ | set_of_closure_id ->
+ relevant_local_closure_ids :=
+ Closure_id.Set.add closure_id
+ !relevant_local_closure_ids;
+ relevant_local_vars_with_closure :=
+ Var_within_closure.Set.add var
+ !relevant_local_vars_with_closure;
+ relevant_set_of_closures_declaration_only :=
+ Set_of_closures_id.Set.add
+ set_of_closure_id
+ !relevant_set_of_closures_declaration_only
+ end
+ | Prim _
+ | Expr _
+ | Const _
+ | Allocated_const _
+ | Read_mutable _ -> ())
+ function_body.body
+ in
+ let rec loop () =
+ if Queue.is_empty queue then
+ ()
+ else begin
+ begin match Queue.pop queue with
+ | Q_export_id export_id ->
+ begin match Export_id.Map.find export_id values with
+ | exception Not_found -> ()
+ | Value_block (_, approxes) ->
+ Array.iter process_approx approxes
+ | Value_closure value_closure ->
+ process_value_set_of_closures value_closure.set_of_closures
+ | Value_set_of_closures soc ->
+ process_value_set_of_closures soc
+ | _ -> ()
+ end
+ | Q_symbol symbol ->
+ let compilation_unit = Symbol.compilation_unit symbol in
+ if Compilation_unit.is_current compilation_unit then begin
+ match Symbol.Map.find symbol symbol_id with
+ | exception Not_found ->
+ Misc.fatal_errorf "cannot find symbol's export id %a\n"
+ Symbol.print symbol
+ | export_id ->
+ conditionally_add_export_id export_id
+ end
+ | Q_set_of_closures_id set_of_closures_id ->
+ begin match
+ Set_of_closures_id.Map.find
+ set_of_closures_id function_declarations_map
+ with
+ | exception Not_found -> ()
+ | function_declarations ->
+ Variable.Map.iter
+ (fun (_ : Variable.t) (fun_decl : A.function_declaration) ->
+ match fun_decl.function_body with
+ | None -> ()
+ | Some function_body -> process_function_body function_body)
+ function_declarations.funs
+ end
+ end;
+ loop ()
+ end
+ in
+ Queue.add (Q_symbol root_symbol) queue;
+ loop ();
+
+ Closure_id.Map.iter (fun closure_id set_of_closure_id ->
+ if Set_of_closures_id.Set.mem
+ set_of_closure_id !relevant_set_of_closures
+ then begin
+ relevant_local_closure_ids :=
+ Closure_id.Set.add closure_id !relevant_local_closure_ids
+ end)
+ closure_id_to_set_of_closures_id;
+
+ Set_of_closures_id.Set.iter (fun set_of_closures_id ->
+ match
+ Set_of_closures_id.Map.find set_of_closures_id sets_of_closures_map
+ with
+ | exception Not_found -> ()
+ | set_of_closures ->
+ Variable.Map.iter (fun var _ ->
+ relevant_local_vars_with_closure :=
+ Var_within_closure.Set.add
+ (Var_within_closure.wrap var)
+ !relevant_local_vars_with_closure)
+ set_of_closures.free_vars)
+ !relevant_set_of_closures;
+
+ { symbols = !relevant_symbols;
+ export_ids = !relevant_export_ids;
+ set_of_closure_ids = !relevant_set_of_closures;
+ set_of_closure_ids_keep_declaration =
+ !relevant_set_of_closures_declaration_only;
+ relevant_imported_closure_ids = !relevant_imported_closure_ids;
+ relevant_local_closure_ids = !relevant_local_closure_ids;
+ relevant_imported_vars_within_closure =
+ !relevant_imported_vars_within_closure;
+ relevant_local_vars_within_closure =
+ !relevant_local_vars_with_closure;
+ }
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Fu Yong Quah, Jane Street Europe *)
+(* *)
+(* Copyright 2017 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+type symbols_to_export =
+ { symbols : Symbol.Set.t;
+ export_ids : Export_id.Set.t;
+ set_of_closure_ids : Set_of_closures_id.Set.t;
+ set_of_closure_ids_keep_declaration : Set_of_closures_id.Set.t;
+ relevant_imported_closure_ids : Closure_id.Set.t;
+ relevant_local_closure_ids : Closure_id.Set.t;
+ relevant_imported_vars_within_closure : Var_within_closure.Set.t;
+ relevant_local_vars_within_closure : Var_within_closure.Set.t;
+ }
+
+(** Computes the transitive closure in [Symbol.t], [Closure_id.t] and
+ [Set_of_closures_id.t] and determines which ones of those should be
+ exported (i.e: included in the cmx files).
+**)
+val traverse
+ : sets_of_closures_map: Flambda.set_of_closures Set_of_closures_id.Map.t
+ -> closure_id_to_set_of_closures_id:
+ Set_of_closures_id.t Closure_id.Map.t
+ -> function_declarations_map:
+ Simple_value_approx.function_declarations Set_of_closures_id.Map.t
+ -> values: Export_info.descr Export_id.Map.t
+ -> symbol_id: Export_id.t Symbol.Map.t
+ -> root_symbol: Symbol.t
+ -> symbols_to_export
../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
../byterun/caml/stack.h ../byterun/caml/startup_aux.h
-terminfo.$(O): terminfo.c ../byterun/caml/config.h ../byterun/caml/m.h \
- ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
- ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
md5.$(O): md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
../byterun/caml/mlvalues.h ../byterun/caml/custom.h \
../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
- ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+ ../byterun/caml/signals.h
globroots.$(O): globroots.c ../byterun/caml/memory.h \
../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
../byterun/caml/gc.h ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
../byterun/caml/address_class.h ../byterun/caml/roots.h \
../byterun/caml/signals.h ../byterun/caml/stack.h \
../byterun/caml/sys.h ../byterun/caml/spacetime.h
-spacetime_offline.$(O): spacetime_offline.c ../byterun/caml/alloc.h \
- ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
- ../byterun/caml/s.h ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
- ../byterun/caml/gc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
- ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
- ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
- ../byterun/caml/address_class.h ../byterun/caml/roots.h \
- ../byterun/caml/signals.h ../byterun/caml/stack.h \
- ../byterun/caml/sys.h ../byterun/caml/spacetime.h
afl.$(O): afl.c ../byterun/caml/config.h ../byterun/caml/m.h \
../byterun/caml/s.h ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
../byterun/caml/osdeps.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/hash.h \
../byterun/caml/memory.h ../byterun/caml/gc.h \
../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
- ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+ ../byterun/caml/signals.h
startup_aux.p.$(O): startup_aux.c ../byterun/caml/backtrace.h \
../byterun/caml/mlvalues.h ../byterun/caml/config.h \
../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
../byterun/caml/stack.h ../byterun/caml/startup_aux.h
-terminfo.p.$(O): terminfo.c ../byterun/caml/config.h ../byterun/caml/m.h \
- ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
- ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
md5.p.$(O): md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
../byterun/caml/mlvalues.h ../byterun/caml/custom.h \
../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
- ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+ ../byterun/caml/signals.h
globroots.p.$(O): globroots.c ../byterun/caml/memory.h \
../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
../byterun/caml/gc.h ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
../byterun/caml/address_class.h ../byterun/caml/roots.h \
../byterun/caml/signals.h ../byterun/caml/stack.h \
../byterun/caml/sys.h ../byterun/caml/spacetime.h
-spacetime_offline.p.$(O): spacetime_offline.c ../byterun/caml/alloc.h \
- ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
- ../byterun/caml/s.h ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
- ../byterun/caml/gc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
- ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
- ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
- ../byterun/caml/address_class.h ../byterun/caml/roots.h \
- ../byterun/caml/signals.h ../byterun/caml/stack.h \
- ../byterun/caml/sys.h ../byterun/caml/spacetime.h
afl.p.$(O): afl.c ../byterun/caml/config.h ../byterun/caml/m.h \
../byterun/caml/s.h ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
../byterun/caml/osdeps.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/hash.h \
../byterun/caml/memory.h ../byterun/caml/gc.h \
../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
- ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+ ../byterun/caml/signals.h
startup_aux.d.$(O): startup_aux.c ../byterun/caml/backtrace.h \
../byterun/caml/mlvalues.h ../byterun/caml/config.h \
../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
../byterun/caml/stack.h ../byterun/caml/startup_aux.h
-terminfo.d.$(O): terminfo.c ../byterun/caml/config.h ../byterun/caml/m.h \
- ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
- ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
md5.d.$(O): md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
../byterun/caml/mlvalues.h ../byterun/caml/custom.h \
../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
- ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+ ../byterun/caml/signals.h
globroots.d.$(O): globroots.c ../byterun/caml/memory.h \
../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
../byterun/caml/gc.h ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
../byterun/caml/address_class.h ../byterun/caml/roots.h \
../byterun/caml/signals.h ../byterun/caml/stack.h \
../byterun/caml/sys.h ../byterun/caml/spacetime.h
-spacetime_offline.d.$(O): spacetime_offline.c ../byterun/caml/alloc.h \
- ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
- ../byterun/caml/s.h ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
- ../byterun/caml/gc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
- ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
- ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
- ../byterun/caml/address_class.h ../byterun/caml/roots.h \
- ../byterun/caml/signals.h ../byterun/caml/stack.h \
- ../byterun/caml/sys.h ../byterun/caml/spacetime.h
afl.d.$(O): afl.c ../byterun/caml/config.h ../byterun/caml/m.h \
../byterun/caml/s.h ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
../byterun/caml/osdeps.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/hash.h \
../byterun/caml/memory.h ../byterun/caml/gc.h \
../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
- ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+ ../byterun/caml/signals.h
startup_aux.i.$(O): startup_aux.c ../byterun/caml/backtrace.h \
../byterun/caml/mlvalues.h ../byterun/caml/config.h \
../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
../byterun/caml/stack.h ../byterun/caml/startup_aux.h
-terminfo.i.$(O): terminfo.c ../byterun/caml/config.h ../byterun/caml/m.h \
- ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
- ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
md5.i.$(O): md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
../byterun/caml/mlvalues.h ../byterun/caml/custom.h \
../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
- ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+ ../byterun/caml/signals.h
globroots.i.$(O): globroots.c ../byterun/caml/memory.h \
../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
../byterun/caml/gc.h ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
../byterun/caml/address_class.h ../byterun/caml/roots.h \
../byterun/caml/signals.h ../byterun/caml/stack.h \
../byterun/caml/sys.h ../byterun/caml/spacetime.h
-spacetime_offline.i.$(O): spacetime_offline.c ../byterun/caml/alloc.h \
- ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
- ../byterun/caml/s.h ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
- ../byterun/caml/gc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
- ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
- ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
- ../byterun/caml/address_class.h ../byterun/caml/roots.h \
- ../byterun/caml/signals.h ../byterun/caml/stack.h \
- ../byterun/caml/sys.h ../byterun/caml/spacetime.h
afl.i.$(O): afl.c ../byterun/caml/config.h ../byterun/caml/m.h \
../byterun/caml/s.h ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
../byterun/caml/osdeps.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/hash.h \
../byterun/caml/memory.h ../byterun/caml/gc.h \
../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
- ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+ ../byterun/caml/signals.h
#**************************************************************************
include ../config/Makefile
+include ../Makefile.common
LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \
compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \
- parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \
+ parsing.c gc_ctrl.c md5.c obj.c lexing.c printexc.c callback.c \
weak.c compact.c finalise.c meta.c custom.c main.c globroots.c \
$(UNIX_OR_WIN32).c dynlink.c signals.c debugger.c startup_aux.c \
backtrace.c afl.c bigarray.c
# compiled on the platform where make depend is run
sources := $(LINKEDFILES)
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-
ifeq "$(UNIX_OR_WIN32)" "win32"
LN = cp
sources += ../byterun/unix.c
DFLAGS = $(CFLAGS) -DDEBUG
PFLAGS=$(CFLAGS) -DPROFILING $(NATIVECCPROFOPTS)
ASMOBJS=$(ARCH)nt.$(O)
+ASMFLAGS=
+ifeq ($(WITH_SPACETIME),true)
+ASMFLAGS=/DWITH_SPACETIME
+endif
else
DFLAGS = $(CFLAGS) -g -DDEBUG
PFLAGS=$(CFLAGS) -pg -DPROFILING $(NATIVECCPROFOPTS)
major_gc.$(O) minor_gc.$(O) memory.$(O) alloc.$(O) compare.$(O) \
ints.$(O) floats.$(O) str.$(O) array.$(O) io.$(O) extern.$(O) \
intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) \
- terminfo.$(O) md5.$(O) obj.$(O) lexing.$(O) $(UNIX_OR_WIN32).$(O) \
+ md5.$(O) obj.$(O) lexing.$(O) $(UNIX_OR_WIN32).$(O) \
printexc.$(O) callback.$(O) weak.$(O) compact.$(O) finalise.$(O) \
custom.$(O) globroots.$(O) backtrace_prim.$(O) backtrace.$(O) \
natdynlink.$(O) debugger.$(O) meta.$(O) dynlink.$(O) \
clambda_checks.$(O) spacetime.$(O) spacetime_snapshot.$(O) \
- spacetime_offline.$(O) afl.$(O) bigarray.$(O)
+ afl.$(O) bigarray.$(O)
OBJS=$(COBJS) $(ASMOBJS)
POBJS=$(COBJS:.$(O)=.p.$(O)) $(ASMOBJS:.$(O)=.p.$(O))
PICOBJS=$(COBJS:.$(O)=.pic.$(O)) $(ASMOBJS:.$(O)=.pic.$(O))
-TARGETS = libasmrun.$(A)
+TARGETS_A = libasmrun.$(A)
+TARGETS_SO=
ifeq "$(RUNTIMED)" "true"
-TARGETS += libasmrund.$(A)
+TARGETS_A += libasmrund.$(A)
endif
ifeq "$(RUNTIMEI)" "true"
-TARGETS += libasmruni.$(A)
+TARGETS_A += libasmruni.$(A)
endif
ifeq "$(PROFILING)" "true"
-TARGETS += libasmrunp.$(A)
+TARGETS_A += libasmrunp.$(A)
endif
ifeq "$(UNIX_OR_WIN32)" "unix"
ifeq "$(SUPPORTS_SHARED_LIBRARIES)" "true"
-TARGETS += libasmrun_pic.$(A) libasmrun_shared.$(SO)
+TARGETS_A += libasmrun_pic.$(A)
+TARGETS_SO += libasmrun_shared.$(SO)
endif
endif
.PHONY: all
-all: $(TARGETS)
+all: $(TARGETS_A) $(TARGETS_SO)
libasmrun.$(A): $(OBJS)
$(call MKLIB,$@, $^)
.PHONY: install
install:
- cp $(TARGETS) "$(INSTALL_LIBDIR)"
+ $(INSTALL_DATA) $(TARGETS_A) "$(INSTALL_LIBDIR)"
+ if test -n "$(TARGETS_SO)"; then \
+ $(INSTALL_PROG) $(TARGETS_SO) "$(INSTALL_LIBDIR)"; \
+ fi
$(LINKEDFILES): %.c: ../byterun/%.c
$(LN) $< $@
$(ASPP) $(ASPPFLAGS) $(SHAREDCCCOMPOPTS) -o $@ $<
%.obj: %.asm
- $(ASM)$@ $<
+ $(ASM)$@ $(ASMFLAGS) $<
%.pic.obj: %.asm
- $(ASM)$@ $<
+ $(ASM)$@ $(ASMFLAGS) $<
.PHONY: clean
clean:
# define PREPARE_FOR_C_CALL
# define CLEANUP_AFTER_C_CALL
# define STACK_PROBE_SIZE $32768
+#endif
+
+/* Registers holding arguments of C functions. */
+
+#if defined(SYS_mingw64) || defined(SYS_cygwin)
+#define C_ARG_1 %rcx
+#define C_ARG_2 %rdx
+#define C_ARG_3 %r8
+#define C_ARG_4 %r9
+#else
+#define C_ARG_1 %rdi
+#define C_ARG_2 %rsi
+#define C_ARG_3 %rdx
+#define C_ARG_4 %rcx
#endif
.text
pushq %rdi; CFI_ADJUST (8)
pushq %rsi; CFI_ADJUST (8)
/* No need to push %r12: it's callee-save. */
- movq %r12, %rdi
- LEA_VAR(caml_start_program, %rsi)
+ movq %r12, C_ARG_1
+ LEA_VAR(caml_start_program, C_ARG_2)
call GCALL(caml_spacetime_c_to_ocaml)
popq %rsi; CFI_ADJUST (-8)
popq %rdi; CFI_ADJUST (-8)
jmp LBL(109)
CFI_ENDPROC
-/* Registers holding arguments of C functions. */
-
-#if defined(SYS_mingw64) || defined(SYS_cygwin)
-#define C_ARG_1 %rcx
-#define C_ARG_2 %rdx
-#define C_ARG_3 %r8
-#define C_ARG_4 %r9
-#else
-#define C_ARG_1 %rdi
-#define C_ARG_2 %rsi
-#define C_ARG_3 %rdx
-#define C_ARG_4 %rcx
-#endif
-
/* Raise an exception from OCaml */
FUNCTION(G(caml_raise_exn))
EXTRN caml_backtrace_pos: DWORD
EXTRN caml_backtrace_active: DWORD
EXTRN caml_stash_backtrace: NEAR
+IFDEF WITH_SPACETIME
+ EXTRN caml_spacetime_trie_node_ptr: QWORD
+ EXTRN caml_spacetime_c_to_ocaml: NEAR
+ENDIF
.CODE
; Save caml_young_ptr, caml_exception_pointer
mov caml_young_ptr, r15
mov caml_exception_pointer, r14
+IFDEF WITH_SPACETIME
+ mov caml_spacetime_trie_node_ptr, r13
+ENDIF
; Build array of registers, save it into caml_gc_regs
push rbp
push r11
pop r12
mov caml_last_return_address, r12
mov caml_bottom_of_stack, rsp
+IFDEF WITH_SPACETIME
+ ; Record the trie node hole pointer that corresponds to
+ ; [caml_last_return_address]
+ mov caml_spacetime_trie_node_ptr, r13
+ENDIF
; Touch the stack to trigger a recoverable segfault
; if insufficient space remains
sub rsp, 01000h
; Common code for caml_start_program and caml_callback*
L106:
; Build a callback link
+IFDEF WITH_SPACETIME
+ push caml_spacetime_trie_node_ptr
+ELSE
sub rsp, 8 ; stack 16-aligned
+ENDIF
push caml_gc_regs
push caml_last_return_address
push caml_bottom_of_stack
+IFDEF WITH_SPACETIME
+ ; Save arguments to caml_callback
+ push rax
+ push rbx
+ push rdi
+ push rsi
+ ; No need to push r12: it is callee-save.
+ mov rcx, r12
+ lea rdx, caml_start_program
+ call caml_spacetime_c_to_ocaml
+ pop rsi
+ pop rdi
+ pop rbx
+ pop rax
+ENDIF
; Setup alloc ptr and exception ptr
mov r15, caml_young_ptr
mov r14, caml_exception_pointer
push r13
push r14
mov r14, rsp
+IFDEF WITH_SPACETIME
+ mov r13, caml_spacetime_trie_node_ptr
+ENDIF
; Call the OCaml code
call r12
L107:
pop caml_bottom_of_stack
pop caml_last_return_address
pop caml_gc_regs
+IFDEF WITH_SPACETIME
+ pop caml_spacetime_trie_node_ptr
+ELSE
add rsp, 8
+ENDIF
; Restore callee-save registers.
movapd xmm6, OWORD PTR [rsp + 0*16]
movapd xmm7, OWORD PTR [rsp + 1*16]
WORD 0 ; no roots here
ALIGN 8
+IFDEF WITH_SPACETIME
+ .DATA
+ PUBLIC caml_system__spacetime_shapes
+ ALIGN 8
+caml_system__spacetime_shapes LABEL QWORD
+ QWORD caml_start_program
+ QWORD 2 ; indirect call point to OCaml code
+ QWORD L107 ; in caml_start_program / caml_callback*
+ QWORD 0 ; end of shapes in caml_start_program
+ QWORD 0 ; end of shape table
+ ALIGN 8
+ENDIF
+
PUBLIC caml_negf_mask
ALIGN 16
caml_negf_mask LABEL QWORD
#ifdef HAS_UNISTD
#include <unistd.h>
#endif
+#ifdef _WIN32
+#include <process.h> /* for _getpid */
+#include <direct.h> /* for _wgetcwd */
+#endif
#include "caml/alloc.h"
#include "caml/backtrace_prim.h"
/* We force "noinline" in certain places to be sure we know how many
frames there will be on the stack. */
+#ifdef _MSC_VER
+#define NOINLINE __declspec(noinline)
+#else
#define NOINLINE __attribute__((noinline))
+#endif
#ifdef HAS_LIBUNWIND
#define UNW_LOCAL_ONLY
static const uintnat chunk_size = 1024 * 1024;
+#ifdef _WIN32
+#define strdup_os wcsdup
+#define snprintf_os _snwprintf
+#else
+#define strdup_os strdup
+#define snprintf_os snprintf
+#endif
+
static void reinitialise_free_node_block(void)
{
size_t index;
#define O_BINARY 0
#endif
-#if defined (_WIN32) || defined (_WIN64)
-extern value val_process_id;
-#endif
-
enum {
FEATURE_CALL_COUNTS = 1,
} features;
return Val_unit;
}
-static char* automatic_snapshot_dir;
+static char_os* automatic_snapshot_dir;
static void open_snapshot_channel(void)
{
int fd;
- char filename[8192];
+ char_os filename[8192];
int pid;
-#if defined (_WIN32) || defined (_WIN64)
- pid = Int_val(val_process_id);
+ int filename_len = sizeof(filename)/sizeof(char_os);
+#ifdef _WIN32
+ pid = _getpid();
#else
pid = getpid();
#endif
- snprintf(filename, 8192, "%s/spacetime-%d", automatic_snapshot_dir, pid);
- filename[8191] = '\0';
- fd = open(filename, O_WRONLY | O_CREAT | O_TRUNC | O_BINARY, 0666);
+ snprintf_os(filename, filename_len, _T("%s/spacetime-%d"),
+ automatic_snapshot_dir, pid);
+ filename[filename_len-1] = _T('\0');
+ fd = open_os(filename, O_WRONLY | O_CREAT | O_TRUNC | O_BINARY, 0666);
if (fd == -1) {
automatic_snapshots = 0;
}
was written during that time) and then open a new one. */
int pid;
-#if defined (_WIN32) || defined (_WIN64)
- pid = Int_val(val_process_id);
+#ifdef _WIN32
+ pid = _getpid();
#else
pid = getpid();
#endif
{
/* Note that this is called very early (even prior to GC initialisation). */
- char *ap_interval;
+ char_os *ap_interval;
reinitialise_free_node_block();
caml_spacetime_static_shape_tables = &caml_spacetime_shapes;
- ap_interval = caml_secure_getenv ("OCAML_SPACETIME_INTERVAL");
+ ap_interval = caml_secure_getenv (_T("OCAML_SPACETIME_INTERVAL"));
if (ap_interval != NULL) {
unsigned int interval = 0;
- sscanf(ap_interval, "%u", &interval);
+ sscanf_os(ap_interval, _T("%u"), &interval);
if (interval != 0) {
double time;
- char cwd[4096];
- char* user_specified_automatic_snapshot_dir;
+ char_os cwd[4096];
+ char_os* user_specified_automatic_snapshot_dir;
int dir_ok = 1;
user_specified_automatic_snapshot_dir =
- caml_secure_getenv("OCAML_SPACETIME_SNAPSHOT_DIR");
+ caml_secure_getenv(_T("OCAML_SPACETIME_SNAPSHOT_DIR"));
if (user_specified_automatic_snapshot_dir == NULL) {
#if defined(HAS_GETCWD)
- if (getcwd(cwd, sizeof(cwd)) == NULL) {
+ if (getcwd_os(cwd, sizeof(cwd)/sizeof(char_os)) == NULL) {
dir_ok = 0;
}
#else
dir_ok = 0;
#endif
if (dir_ok) {
- automatic_snapshot_dir = strdup(cwd);
+ automatic_snapshot_dir = strdup_os(cwd);
}
}
else {
automatic_snapshot_dir =
- strdup(user_specified_automatic_snapshot_dir);
+ strdup_os(user_specified_automatic_snapshot_dir);
}
if (dir_ok) {
+++ /dev/null
-/**************************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Mark Shinwell and Leo White, Jane Street Europe */
-/* */
-/* Copyright 2013--2016, Jane Street Group, LLC */
-/* */
-/* All rights reserved. This file is distributed under the terms of */
-/* the GNU Lesser General Public License version 2.1, with the */
-/* special exception on linking described in the file LICENSE. */
-/* */
-/**************************************************************************/
-
-#define CAML_INTERNALS
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <limits.h>
-#include <math.h>
-
-#include "caml/alloc.h"
-#include "caml/config.h"
-#include "caml/fail.h"
-#include "caml/gc.h"
-#include "caml/intext.h"
-#include "caml/major_gc.h"
-#include "caml/memory.h"
-#include "caml/minor_gc.h"
-#include "caml/misc.h"
-#include "caml/mlvalues.h"
-#include "caml/roots.h"
-#include "caml/signals.h"
-#include "caml/stack.h"
-#include "caml/sys.h"
-#include "caml/spacetime.h"
-
-#include "caml/s.h"
-
-#define SPACETIME_PROFINFO_WIDTH 26
-#define Spacetime_profinfo_hd(hd) \
- (Gen_profinfo_hd(SPACETIME_PROFINFO_WIDTH, hd))
-
-#ifdef ARCH_SIXTYFOUR
-
-/* CR-someday lwhite: The following two definitions are copied from spacetime.c
- because they are needed here, but must be inlined in spacetime.c
- for performance. Perhaps a macro or "static inline" would be
- more appropriate. */
-
-c_node* caml_spacetime_offline_c_node_of_stored_pointer_not_null
- (value node_stored)
-{
- CAMLassert(Is_c_node(node_stored));
- return (c_node*) Hp_val(node_stored);
-}
-
-c_node_type caml_spacetime_offline_classify_c_node(c_node* node)
-{
- return (node->pc & 2) ? CALL : ALLOCATION;
-}
-
-CAMLprim value caml_spacetime_compare_node(
- value node1, value node2)
-{
- CAMLassert(!Is_in_value_area(node1));
- CAMLassert(!Is_in_value_area(node2));
-
- if (node1 == node2) {
- return Val_long(0);
- }
- if (node1 < node2) {
- return Val_long(-1);
- }
- return Val_long(1);
-}
-
-CAMLprim value caml_spacetime_unmarshal_trie (value v_channel)
-{
- return caml_input_value_to_outside_heap(v_channel);
-}
-
-CAMLprim value caml_spacetime_node_num_header_words(value unit)
-{
- unit = Val_unit;
- return Val_long(Node_num_header_words);
-}
-
-CAMLprim value caml_spacetime_is_ocaml_node(value node)
-{
- CAMLassert(Is_ocaml_node(node) || Is_c_node(node));
- return Val_bool(Is_ocaml_node(node));
-}
-
-CAMLprim value caml_spacetime_ocaml_function_identifier(value node)
-{
- CAMLassert(Is_ocaml_node(node));
- return caml_copy_int64((uint64_t) Decode_node_pc(Node_pc(node)));
-}
-
-CAMLprim value caml_spacetime_ocaml_tail_chain(value node)
-{
- CAMLassert(Is_ocaml_node(node));
- return Tail_link(node);
-}
-
-CAMLprim value caml_spacetime_classify_direct_call_point
- (value node, value offset)
-{
- uintnat field;
- value callee_node;
-
- CAMLassert(Is_ocaml_node(node));
-
- field = Long_val(offset);
-
- callee_node = Direct_callee_node(node, field);
- if (!Is_block(callee_node)) {
- /* An unused call point (may be a tail call point). */
- return Val_long(0);
- } else if (Is_ocaml_node(callee_node)) {
- return Val_long(1); /* direct call point to OCaml code */
- } else {
- return Val_long(2); /* direct call point to non-OCaml code */
- }
-}
-
-CAMLprim value caml_spacetime_ocaml_allocation_point_annotation
- (value node, value offset)
-{
- uintnat profinfo_shifted;
- profinfo_shifted = (uintnat) Alloc_point_profinfo(node, Long_val(offset));
- return Val_long(Spacetime_profinfo_hd(profinfo_shifted));
-}
-
-CAMLprim value caml_spacetime_ocaml_allocation_point_count
- (value node, value offset)
-{
- value count = Alloc_point_count(node, Long_val(offset));
- CAMLassert(!Is_block(count));
- return count;
-}
-
-CAMLprim value caml_spacetime_ocaml_direct_call_point_callee_node
- (value node, value offset)
-{
- return Direct_callee_node(node, Long_val(offset));
-}
-
-CAMLprim value caml_spacetime_ocaml_direct_call_point_call_count
-(value node, value offset)
-{
- return Direct_call_count(node, Long_val(offset));
-}
-
-CAMLprim value caml_spacetime_ocaml_indirect_call_point_callees
- (value node, value offset)
-{
- value callees = Indirect_pc_linked_list(node, Long_val(offset));
- CAMLassert(Is_block(callees));
- CAMLassert(Is_c_node(callees));
- return callees;
-}
-
-CAMLprim value caml_spacetime_c_node_is_call(value node)
-{
- c_node* c_node;
- CAMLassert(node != (value) NULL);
- CAMLassert(Is_c_node(node));
- c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
- switch (caml_spacetime_offline_classify_c_node(c_node)) {
- case CALL: return Val_true;
- case ALLOCATION: return Val_false;
- }
- CAMLassert(0);
- return Val_unit; /* silence compiler warning */
-}
-
-CAMLprim value caml_spacetime_c_node_next(value node)
-{
- c_node* c_node;
-
- CAMLassert(node != (value) NULL);
- CAMLassert(Is_c_node(node));
- c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
- CAMLassert(c_node->next == Val_unit || Is_c_node(c_node->next));
- return c_node->next;
-}
-
-CAMLprim value caml_spacetime_c_node_call_site(value node)
-{
- c_node* c_node;
- CAMLassert(node != (value) NULL);
- CAMLassert(Is_c_node(node));
- c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
- return caml_copy_int64((uint64_t) Decode_c_node_pc(c_node->pc));
-}
-
-CAMLprim value caml_spacetime_c_node_callee_node(value node)
-{
- c_node* c_node;
- CAMLassert(node != (value) NULL);
- CAMLassert(Is_c_node(node));
- c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
- CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == CALL);
- /* This might be an uninitialised tail call point: for example if an OCaml
- callee was indirectly called but the callee wasn't instrumented (e.g. a
- leaf function that doesn't allocate). */
- if (Is_tail_caller_node_encoded(c_node->data.call.callee_node)) {
- return Val_unit;
- }
- return c_node->data.call.callee_node;
-}
-
-CAMLprim value caml_spacetime_c_node_call_count(value node)
-{
- c_node* c_node;
- CAMLassert(node != (value) NULL);
- CAMLassert(Is_c_node(node));
- c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
- CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == CALL);
- if (Is_tail_caller_node_encoded(c_node->data.call.callee_node)) {
- return Val_long(0);
- }
- return c_node->data.call.call_count;
-}
-
-CAMLprim value caml_spacetime_c_node_profinfo(value node)
-{
- c_node* c_node;
- CAMLassert(node != (value) NULL);
- CAMLassert(Is_c_node(node));
- c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
- CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION);
- CAMLassert(!Is_block(c_node->data.allocation.profinfo));
- return Val_long(Spacetime_profinfo_hd(c_node->data.allocation.profinfo));
-}
-
-CAMLprim value caml_spacetime_c_node_allocation_count(value node)
-{
- c_node* c_node;
- CAMLassert(node != (value) NULL);
- CAMLassert(Is_c_node(node));
- c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
- CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION);
- CAMLassert(!Is_block(c_node->data.allocation.count));
- return c_node->data.allocation.count;
-}
-
-#endif
extern int caml_parser_trace;
CAMLexport header_t caml_atom_table[256];
char * caml_code_area_start, * caml_code_area_end;
+struct ext_table caml_code_fragments_table;
/* Initialize the atom table and the static data and code area limits. */
| Lvar id ->
begin try Ident.find_same id env with Not_found -> RHS_nonrec end
| Lfunction{params} as funct ->
- RHS_function (1 + IdentSet.cardinal(free_variables funct),
+ RHS_function (1 + Ident.Set.cardinal(free_variables funct),
List.length params)
| Llet (Strict, _k, id, Lprim (Pduprecord (kind, size), _, _), body)
when check_recordwith_updates id body ->
| Psubfloat -> Kccall("caml_sub_float", 2)
| Pmulfloat -> Kccall("caml_mul_float", 2)
| Pdivfloat -> Kccall("caml_div_float", 2)
- | Pfloatcomp Ceq -> Kccall("caml_eq_float", 2)
- | Pfloatcomp Cneq -> Kccall("caml_neq_float", 2)
- | Pfloatcomp Clt -> Kccall("caml_lt_float", 2)
- | Pfloatcomp Cgt -> Kccall("caml_gt_float", 2)
- | Pfloatcomp Cle -> Kccall("caml_le_float", 2)
- | Pfloatcomp Cge -> Kccall("caml_ge_float", 2)
| Pstringlength -> Kccall("caml_ml_string_length", 1)
| Pbyteslength -> Kccall("caml_ml_bytes_length", 1)
| Pstringrefs -> Kccall("caml_string_get", 2)
| Pbytesrefs -> Kccall("caml_bytes_get", 2)
| Pbytessets -> Kccall("caml_bytes_set", 3)
- | Pstringrefu | Pbytesrefu -> Kgetstringchar
- | Pbytessetu -> Ksetstringchar
+ | Pstringrefu -> Kgetstringchar
+ | Pbytesrefu -> Kgetbyteschar
+ | Pbytessetu -> Ksetbyteschar
| Pstring_load_16(_) -> Kccall("caml_string_get16", 2)
| Pstring_load_32(_) -> Kccall("caml_string_get32", 2)
| Pstring_load_64(_) -> Kccall("caml_string_get64", 2)
- | Pstring_set_16(_) -> Kccall("caml_string_set16", 3)
- | Pstring_set_32(_) -> Kccall("caml_string_set32", 3)
- | Pstring_set_64(_) -> Kccall("caml_string_set64", 3)
+ | Pbytes_set_16(_) -> Kccall("caml_bytes_set16", 3)
+ | Pbytes_set_32(_) -> Kccall("caml_bytes_set32", 3)
+ | Pbytes_set_64(_) -> Kccall("caml_bytes_set64", 3)
+ | Pbytes_load_16(_) -> Kccall("caml_bytes_get16", 2)
+ | Pbytes_load_32(_) -> Kccall("caml_bytes_get32", 2)
+ | Pbytes_load_64(_) -> Kccall("caml_bytes_get64", 2)
| Parraylength _ -> Kvectlength
| Parrayrefs Pgenarray -> Kccall("caml_array_get", 2)
| Parrayrefs Pfloatarray -> Kccall("caml_floatarray_get", 2)
Kccall(Printf.sprintf "caml_sys_const_%s" const_name, 1)
| Pisint -> Kisint
| Pisout -> Kisout
- | Pbittest -> Kccall("caml_bitvect_test", 2)
| Pbintofint bi -> comp_bint_primitive bi "of_int" args
| Pintofbint bi -> comp_bint_primitive bi "to_int" args
| Pcvtbint(Pint32, Pnativeint) -> Kccall("caml_nativeint_of_int32", 1)
| Plsrbint bi -> comp_bint_primitive bi "shift_right_unsigned" args
| Pasrbint bi -> comp_bint_primitive bi "shift_right" args
| Pbintcomp(_, Ceq) -> Kccall("caml_equal", 2)
- | Pbintcomp(_, Cneq) -> Kccall("caml_notequal", 2)
+ | Pbintcomp(_, Cne) -> Kccall("caml_notequal", 2)
| Pbintcomp(_, Clt) -> Kccall("caml_lessthan", 2)
| Pbintcomp(_, Cgt) -> Kccall("caml_greaterthan", 2)
| Pbintcomp(_, Cle) -> Kccall("caml_lessequal", 2)
| Pbswap16 -> Kccall("caml_bswap16", 1)
| Pbbswap(bi) -> comp_bint_primitive bi "bswap" args
| Pint_as_pointer -> Kccall("caml_int_as_pointer", 1)
+ | Pbytes_to_string -> Kccall("caml_string_of_bytes", 1)
+ | Pbytes_of_string -> Kccall("caml_bytes_of_string", 1)
| _ -> fatal_error "Bytegen.comp_primitive"
let is_immed n = immed_min <= n && n <= immed_max
end
| Lfunction{params; body} -> (* assume kind = Curried *)
let lbl = new_label() in
- let fv = IdentSet.elements(free_variables exp) in
+ let fv = Ident.Set.elements(free_variables exp) in
let to_compile =
{ params = params; body = body; label = lbl;
free_vars = fv; num_defs = 1; rec_vars = []; rec_pos = 0 } in
decl then begin
(* let rec of functions *)
let fv =
- IdentSet.elements (free_variables (Lletrec(decl, lambda_unit))) in
+ Ident.Set.elements (free_variables (Lletrec(decl, lambda_unit))) in
let rec_idents = List.map (fun (id, _lam) -> id) decl in
let rec comp_fun pos = function
[] -> []
in
comp_init env sz decl_size
end
- | Lprim((Pidentity | Popaque | Pbytes_to_string | Pbytes_of_string), [arg], _)
- ->
+ | Lprim((Pidentity | Popaque), [arg], _) ->
comp_expr env arg sz cont
| Lprim(Pignore, [arg], _) ->
comp_expr env arg sz (add_const_unit cont)
Misc.fatal_error "Bytegen.comp_expr: Pduparray takes exactly one arg"
(* Integer first for enabling further optimization (cf. emitcode.ml) *)
| Lprim (Pintcomp c, [arg ; (Lconst _ as k)], _) ->
- let p = Pintcomp (commute_comparison c)
+ let p = Pintcomp (swap_integer_comparison c)
and args = [k ; arg] in
comp_args env args sz (comp_primitive p args :: cont)
+ | Lprim (Pfloatcomp cmp, args, _) ->
+ let cont =
+ match cmp with
+ | CFeq -> Kccall("caml_eq_float", 2) :: cont
+ | CFneq -> Kccall("caml_neq_float", 2) :: cont
+ | CFlt -> Kccall("caml_lt_float", 2) :: cont
+ | CFnlt -> Kccall("caml_lt_float", 2) :: Kboolnot :: cont
+ | CFgt -> Kccall("caml_gt_float", 2) :: cont
+ | CFngt -> Kccall("caml_gt_float", 2) :: Kboolnot :: cont
+ | CFle -> Kccall("caml_le_float", 2) :: cont
+ | CFnle -> Kccall("caml_le_float", 2) :: Kboolnot :: cont
+ | CFge -> Kccall("caml_ge_float", 2) :: cont
+ | CFnge -> Kccall("caml_ge_float", 2) :: Kboolnot :: cont
+ in
+ comp_args env args sz cont
| Lprim(p, args, _) ->
comp_args env args sz (comp_primitive p args :: cont)
| Lstaticcatch (body, (i, vars) , handler) ->
Klabel lbl_loop :: Kcheck_signals ::
comp_expr (add_var param (sz+1) env) body (sz+2)
(Kacc 1 :: Kpush :: Koffsetint offset :: Kassign 2 ::
- Kacc 1 :: Kintcomp Cneq :: Kbranchif lbl_loop ::
+ Kacc 1 :: Kintcomp Cne :: Kbranchif lbl_loop ::
Klabel lbl_exit :: add_const_unit (add_pop 2 cont))))
| Lswitch(arg, sw, _loc) ->
let (branch, cont1) = make_branch cont in
let act_consts = Array.make sw.sw_numconsts 0
and act_blocks = Array.make sw.sw_numblocks 0 in
begin match sw.sw_failaction with (* default is index 0 *)
- | Some fail -> ignore (store.act_store fail)
+ | Some fail -> ignore (store.act_store () fail)
| None -> ()
end ;
List.iter
- (fun (n, act) -> act_consts.(n) <- store.act_store act) sw.sw_consts;
+ (fun (n, act) -> act_consts.(n) <- store.act_store () act) sw.sw_consts;
List.iter
- (fun (n, act) -> act_blocks.(n) <- store.act_store act) sw.sw_blocks;
+ (fun (n, act) -> act_blocks.(n) <- store.act_store () act) sw.sw_blocks;
(* Compile and label actions *)
let acts = store.act_get () in
(*
val compile_implementation: string -> lambda -> instruction list
val compile_phrase: lambda -> instruction list * instruction list
val reset: unit -> unit
+
+val merge_events : Instruct.debug_event -> Instruct.debug_event -> Instruct.debug_event
(* First pass: determine which units are needed *)
-module IdentSet = Lambda.IdentSet
-
-let missing_globals = ref IdentSet.empty
+let missing_globals = ref Ident.Set.empty
let is_required (rel, _pos) =
match rel with
Reloc_setglobal id ->
- IdentSet.mem id !missing_globals
+ Ident.Set.mem id !missing_globals
| _ -> false
let add_required compunit =
let add_required_by_reloc (rel, _pos) =
match rel with
Reloc_getglobal id ->
- missing_globals := IdentSet.add id !missing_globals
+ missing_globals := Ident.Set.add id !missing_globals
| _ -> ()
in
let add_required_for_effects id =
- missing_globals := IdentSet.add id !missing_globals
+ missing_globals := Ident.Set.add id !missing_globals
in
List.iter add_required_by_reloc compunit.cu_reloc;
List.iter add_required_for_effects compunit.cu_required_globals
let remove_required (rel, _pos) =
match rel with
Reloc_setglobal id ->
- missing_globals := IdentSet.remove id !missing_globals
+ missing_globals := Ident.Set.remove id !missing_globals
| _ -> ()
let scan_file obj_name tolink =
(* Transform a file name into an absolute file name *)
let make_absolute file =
- if Filename.is_relative file
- then Filename.concat (Sys.getcwd()) file
- else file
+ if not (Filename.is_relative file) then file
+ else Location.rewrite_absolute_path
+ (Filename.concat (Sys.getcwd()) file)
(* Create a bytecode executable file *)
else "stdlib.cma" :: (objfiles @ ["std_exit.cmo"]) in
let tolink = List.fold_right scan_file objfiles [] in
let missing_modules =
- IdentSet.filter (fun id -> not (Ident.is_predef_exn id)) !missing_globals
+ Ident.Set.filter (fun id -> not (Ident.is_predef_exn id)) !missing_globals
in
begin
- match IdentSet.elements missing_modules with
+ match Ident.Set.elements missing_modules with
| [] -> ()
| id :: _ -> raise (Error (Required_module_unavailable (Ident.name id)))
end;
lib_ccobjs := [];
lib_ccopts := [];
lib_dllibs := [];
- missing_globals := IdentSet.empty;
+ missing_globals := Ident.Set.empty;
Consistbl.clear crc_interfaces;
implementations_defined := [];
debug_info := [];
let path = ev.ev_loc.Location.loc_start.Lexing.pos_fname in
let abspath = Location.absolute_path path in
debug_dirs := StringSet.add (Filename.dirname abspath) !debug_dirs;
- if Filename.is_relative path then
- debug_dirs := StringSet.add (Sys.getcwd ()) !debug_dirs;
+ if Filename.is_relative path then begin
+ let cwd = Location.rewrite_absolute_path (Sys.getcwd ()) in
+ debug_dirs := StringSet.add cwd !debug_dirs;
+ end;
ev.ev_pos <- !out_position;
events := ev :: !events
(* Emission of one instruction *)
let emit_comp = function
-| Ceq -> out opEQ | Cneq -> out opNEQ
+| Ceq -> out opEQ | Cne -> out opNEQ
| Clt -> out opLTINT | Cle -> out opLEINT
| Cgt -> out opGTINT | Cge -> out opGEINT
and emit_branch_comp = function
-| Ceq -> out opBEQ | Cneq -> out opBNEQ
+| Ceq -> out opBEQ | Cne -> out opBNEQ
| Clt -> out opBLTINT | Cle -> out opBLEINT
| Cgt -> out opBGTINT | Cge -> out opBGEINT
| Kgetvectitem -> out opGETVECTITEM
| Ksetvectitem -> out opSETVECTITEM
| Kgetstringchar -> out opGETSTRINGCHAR
- | Ksetstringchar -> out opSETSTRINGCHAR
+ | Kgetbyteschar -> out opGETBYTESCHAR
+ | Ksetbyteschar -> out opSETBYTESCHAR
| Kbranch lbl -> out opBRANCH; out_label lbl
| Kbranchif lbl -> out opBRANCHIF; out_label lbl
| Kbranchifnot lbl -> out opBRANCHIFNOT; out_label lbl
(* Emission of a list of instructions. Include some peephole optimization. *)
+let remerge_events ev1 = function
+ | Kevent ev2 :: c ->
+ Kevent (Bytegen.merge_events ev1 ev2) :: c
+ | c -> Kevent ev1 :: c
+
let rec emit = function
[] -> ()
(* Peephole optimizations *)
emit rem
| Kpush::Kconst k::Kintcomp c::Kbranchifnot lbl::rem
when is_immed_const k ->
- emit_branch_comp (negate_comparison c) ;
+ emit_branch_comp (negate_integer_comparison c) ;
out_const k ;
out_label lbl ;
emit rem
out opPUSHGETGLOBAL; slot_for_literal sc
end;
emit c
- | Kpush :: (Kevent {ev_kind = Event_before} as ev) ::
+ | Kpush :: (Kevent ({ev_kind = Event_before} as ev)) ::
(Kgetglobal _ as instr1) :: (Kgetfield _ as instr2) :: c ->
- emit (Kpush :: instr1 :: instr2 :: ev :: c)
- | Kpush :: (Kevent {ev_kind = Event_before} as ev) ::
+ emit (Kpush :: instr1 :: instr2 :: remerge_events ev c)
+ | Kpush :: (Kevent ({ev_kind = Event_before} as ev)) ::
(Kacc _ | Kenvacc _ | Koffsetclosure _ | Kgetglobal _ | Kconst _ as instr)::
c ->
- emit (Kpush :: instr :: ev :: c)
+ emit (Kpush :: instr :: remerge_events ev c)
| Kgetglobal id :: Kgetfield n :: c ->
out opGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c
(* Default case *)
| Kgetvectitem
| Ksetvectitem
| Kgetstringchar
- | Ksetstringchar
+ | Kgetbyteschar
+ | Ksetbyteschar
| Kbranch of label
| Kbranchif of label
| Kbranchifnot of label
| Kccall of string * int
| Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint
| Kandint | Korint | Kxorint | Klslint | Klsrint | Kasrint
- | Kintcomp of comparison
+ | Kintcomp of integer_comparison
| Koffsetint of int
| Koffsetref of int
| Kisint
| Kgetvectitem
| Ksetvectitem
| Kgetstringchar
- | Ksetstringchar
+ | Kgetbyteschar
+ | Ksetbyteschar
| Kbranch of label
| Kbranchif of label
| Kbranchifnot of label
| Kccall of string * int
| Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint
| Kandint | Korint | Kxorint | Klslint | Klsrint | Kasrint
- | Kintcomp of comparison
+ | Kintcomp of integer_comparison
| Koffsetint of int
| Koffsetref of int
| Kisint
| Ostype_cygwin
| Backend_type
-type loc_kind =
- | Loc_FILE
- | Loc_LINE
- | Loc_MODULE
- | Loc_LOC
- | Loc_POS
-
type immediate_or_pointer =
| Immediate
| Pointer
| Pignore
| Prevapply
| Pdirapply
- | Ploc of loc_kind
(* Globals *)
| Pgetglobal of Ident.t
| Psetglobal of Ident.t
| Psetfloatfield of int * initialization_or_assignment
| Pduprecord of Types.record_representation * int
(* Force lazy values *)
- | Plazyforce
(* External call *)
| Pccall of Primitive.description
(* Exceptions *)
| Pdivint of is_safe | Pmodint of is_safe
| Pandint | Porint | Pxorint
| Plslint | Plsrint | Pasrint
- | Pintcomp of comparison
+ | Pintcomp of integer_comparison
| Poffsetint of int
| Poffsetref of int
(* Float operations *)
| Pintoffloat | Pfloatofint
| Pnegfloat | Pabsfloat
| Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
- | Pfloatcomp of comparison
+ | Pfloatcomp of float_comparison
(* String operations *)
| Pstringlength | Pstringrefu | Pstringrefs
| Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
| Pisint
(* Test if the (integer) argument is outside an interval *)
| Pisout
- (* Bitvect operations *)
- | Pbittest
(* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
| Pbintofint of boxed_integer
| Pintofbint of boxed_integer
| Plslbint of boxed_integer
| Plsrbint of boxed_integer
| Pasrbint of boxed_integer
- | Pbintcomp of boxed_integer * comparison
+ | Pbintcomp of boxed_integer * integer_comparison
(* Operations on big arrays: (unsafe, #dimensions, kind, layout) *)
| Pbigarrayref of bool * int * bigarray_kind * bigarray_layout
| Pbigarrayset of bool * int * bigarray_kind * bigarray_layout
| Pstring_load_16 of bool
| Pstring_load_32 of bool
| Pstring_load_64 of bool
- | Pstring_set_16 of bool
- | Pstring_set_32 of bool
- | Pstring_set_64 of bool
+ | Pbytes_load_16 of bool
+ | Pbytes_load_32 of bool
+ | Pbytes_load_64 of bool
+ | Pbytes_set_16 of bool
+ | Pbytes_set_32 of bool
+ | Pbytes_set_64 of bool
(* load/set 16,32,64 bits from a
(char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
| Pbigstring_load_16 of bool
(* Inhibition of optimisation *)
| Popaque
-and comparison =
- Ceq | Cneq | Clt | Cgt | Cle | Cge
+and integer_comparison =
+ Ceq | Cne | Clt | Cgt | Cle | Cge
+
+and float_comparison =
+ CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge
and value_kind =
Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
| None -> ()
| Some e -> f e
-let iter f = function
+let iter_head_constructor f = function
Lvar _
| Lconst _ -> ()
| Lapply{ap_func = fn; ap_args = args} ->
| Lifused (_v, e) ->
f e
+let rec free_variables = function
+ | Lvar id -> Ident.Set.singleton id
+ | Lconst _ -> Ident.Set.empty
+ | Lapply{ap_func = fn; ap_args = args} ->
+ free_variables_list (free_variables fn) args
+ | Lfunction{body; params} ->
+ Ident.Set.diff (free_variables body)
+ (Ident.Set.of_list params)
+ | Llet(_str, _k, id, arg, body) ->
+ Ident.Set.union
+ (free_variables arg)
+ (Ident.Set.remove id (free_variables body))
+ | Lletrec(decl, body) ->
+ let set = free_variables_list (free_variables body) (List.map snd decl) in
+ Ident.Set.diff set (Ident.Set.of_list (List.map fst decl))
+ | Lprim(_p, args, _loc) ->
+ free_variables_list Ident.Set.empty args
+ | Lswitch(arg, sw,_) ->
+ let set =
+ free_variables_list
+ (free_variables_list (free_variables arg)
+ (List.map snd sw.sw_consts))
+ (List.map snd sw.sw_blocks)
+ in
+ begin match sw.sw_failaction with
+ | None -> set
+ | Some failaction -> Ident.Set.union set (free_variables failaction)
+ end
+ | Lstringswitch (arg,cases,default,_) ->
+ let set =
+ free_variables_list (free_variables arg)
+ (List.map snd cases)
+ in
+ begin match default with
+ | None -> set
+ | Some default -> Ident.Set.union set (free_variables default)
+ end
+ | Lstaticraise (_,args) ->
+ free_variables_list Ident.Set.empty args
+ | Lstaticcatch(body, (_, params), handler) ->
+ Ident.Set.union
+ (Ident.Set.diff
+ (free_variables handler)
+ (Ident.Set.of_list params))
+ (free_variables body)
+ | Ltrywith(body, param, handler) ->
+ Ident.Set.union
+ (Ident.Set.remove
+ param
+ (free_variables handler))
+ (free_variables body)
+ | Lifthenelse(e1, e2, e3) ->
+ Ident.Set.union
+ (Ident.Set.union (free_variables e1) (free_variables e2))
+ (free_variables e3)
+ | Lsequence(e1, e2) ->
+ Ident.Set.union (free_variables e1) (free_variables e2)
+ | Lwhile(e1, e2) ->
+ Ident.Set.union (free_variables e1) (free_variables e2)
+ | Lfor(v, lo, hi, _dir, body) ->
+ let set = Ident.Set.union (free_variables lo) (free_variables hi) in
+ Ident.Set.union set (Ident.Set.remove v (free_variables body))
+ | Lassign(id, e) ->
+ Ident.Set.add id (free_variables e)
+ | Lsend (_k, met, obj, args, _) ->
+ free_variables_list
+ (Ident.Set.union (free_variables met) (free_variables obj))
+ args
+ | Levent (lam, _evt) ->
+ free_variables lam
+ | Lifused (_v, e) ->
+ (* Shouldn't v be considered a free variable ? *)
+ free_variables e
-module IdentSet = Set.Make(Ident)
-
-let free_ids get l =
- let fv = ref IdentSet.empty in
- let rec free l =
- iter free l;
- fv := List.fold_right IdentSet.add (get l) !fv;
- match l with
- Lfunction{params} ->
- List.iter (fun param -> fv := IdentSet.remove param !fv) params
- | Llet(_str, _k, id, _arg, _body) ->
- fv := IdentSet.remove id !fv
- | Lletrec(decl, _body) ->
- List.iter (fun (id, _exp) -> fv := IdentSet.remove id !fv) decl
- | Lstaticcatch(_e1, (_,vars), _e2) ->
- List.iter (fun id -> fv := IdentSet.remove id !fv) vars
- | Ltrywith(_e1, exn, _e2) ->
- fv := IdentSet.remove exn !fv
- | Lfor(v, _e1, _e2, _dir, _e3) ->
- fv := IdentSet.remove v !fv
- | Lassign(id, _e) ->
- fv := IdentSet.add id !fv
- | Lvar _ | Lconst _ | Lapply _
- | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _
- | Lifthenelse _ | Lsequence _ | Lwhile _
- | Lsend _ | Levent _ | Lifused _ -> ()
- in free l; !fv
-
-let free_variables l =
- free_ids (function Lvar id -> [id] | _ -> []) l
-
-let free_methods l =
- free_ids (function Lsend(Self, Lvar meth, _, _, _) -> [meth] | _ -> []) l
+and free_variables_list set exprs =
+ List.fold_left (fun set expr -> Ident.Set.union (free_variables expr) set)
+ set exprs
(* Check if an action has a "when" guard *)
let raise_count = ref 0
incr raise_count ;
!raise_count
-let negative_raise_count = ref 0
-
-let next_negative_raise_count () =
- decr negative_raise_count ;
- !negative_raise_count
-
(* Anticipated staticraise, for guards *)
let staticfail = Lstaticraise (0,[])
let lam = fn x in Lsequence(lam, make_sequence fn rem)
(* Apply a substitution to a lambda-term.
- Assumes that the bound variables of the lambda-term do not
- belong to the domain of the substitution.
Assumes that the image of the substitution is out of reach
of the bound variables of the lambda-term (no capture). *)
-let subst_lambda s lam =
- let rec subst = function
- Lvar id as l ->
- begin try Ident.find_same id s with Not_found -> l end
+let rec subst s lam =
+ let remove_list l s =
+ List.fold_left (fun s id -> Ident.Map.remove id s) s l
+ in
+ let module M = Ident.Map in
+ match lam with
+ | Lvar id as l ->
+ begin try Ident.Map.find id s with Not_found -> l end
| Lconst _ as l -> l
| Lapply ap ->
- Lapply{ap with ap_func = subst ap.ap_func;
- ap_args = List.map subst ap.ap_args}
+ Lapply{ap with ap_func = subst s ap.ap_func;
+ ap_args = subst_list s ap.ap_args}
| Lfunction{kind; params; body; attr; loc} ->
- Lfunction{kind; params; body = subst body; attr; loc}
- | Llet(str, k, id, arg, body) -> Llet(str, k, id, subst arg, subst body)
- | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body)
- | Lprim(p, args, loc) -> Lprim(p, List.map subst args, loc)
+ let s = List.fold_right Ident.Map.remove params s in
+ Lfunction{kind; params; body = subst s body; attr; loc}
+ | Llet(str, k, id, arg, body) ->
+ Llet(str, k, id, subst s arg, subst (Ident.Map.remove id s) body)
+ | Lletrec(decl, body) ->
+ let s =
+ List.fold_left (fun s (id, _) -> Ident.Map.remove id s)
+ s decl
+ in
+ Lletrec(List.map (subst_decl s) decl, subst s body)
+ | Lprim(p, args, loc) -> Lprim(p, subst_list s args, loc)
| Lswitch(arg, sw, loc) ->
- Lswitch(subst arg,
- {sw with sw_consts = List.map subst_case sw.sw_consts;
- sw_blocks = List.map subst_case sw.sw_blocks;
- sw_failaction = subst_opt sw.sw_failaction; },
+ Lswitch(subst s arg,
+ {sw with sw_consts = List.map (subst_case s) sw.sw_consts;
+ sw_blocks = List.map (subst_case s) sw.sw_blocks;
+ sw_failaction = subst_opt s sw.sw_failaction; },
loc)
| Lstringswitch (arg,cases,default,loc) ->
Lstringswitch
- (subst arg,List.map subst_strcase cases,subst_opt default,loc)
- | Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args)
- | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2)
- | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2)
- | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst e1, subst e2, subst e3)
- | Lsequence(e1, e2) -> Lsequence(subst e1, subst e2)
- | Lwhile(e1, e2) -> Lwhile(subst e1, subst e2)
- | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3)
- | Lassign(id, e) -> Lassign(id, subst e)
+ (subst s arg,List.map (subst_strcase s) cases,subst_opt s default,loc)
+ | Lstaticraise (i,args) -> Lstaticraise (i, subst_list s args)
+ | Lstaticcatch(body, (id, params), handler) ->
+ Lstaticcatch(subst s body, (id, params),
+ subst (remove_list params s) handler)
+ | Ltrywith(body, exn, handler) ->
+ Ltrywith(subst s body, exn, subst (Ident.Map.remove exn s) handler)
+ | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst s e1, subst s e2, subst s e3)
+ | Lsequence(e1, e2) -> Lsequence(subst s e1, subst s e2)
+ | Lwhile(e1, e2) -> Lwhile(subst s e1, subst s e2)
+ | Lfor(v, lo, hi, dir, body) ->
+ Lfor(v, subst s lo, subst s hi, dir,
+ subst (Ident.Map.remove v s) body)
+ | Lassign(id, e) ->
+ assert(not (Ident.Map.mem id s));
+ Lassign(id, subst s e)
| Lsend (k, met, obj, args, loc) ->
- Lsend (k, subst met, subst obj, List.map subst args, loc)
- | Levent (lam, evt) -> Levent (subst lam, evt)
- | Lifused (v, e) -> Lifused (v, subst e)
- and subst_decl (id, exp) = (id, subst exp)
- and subst_case (key, case) = (key, subst case)
- and subst_strcase (key, case) = (key, subst case)
- and subst_opt = function
- | None -> None
- | Some e -> Some (subst e)
- in subst lam
+ Lsend (k, subst s met, subst s obj, subst_list s args, loc)
+ | Levent (lam, evt) -> Levent (subst s lam, evt)
+ | Lifused (v, e) -> Lifused (v, subst s e)
+and subst_list s l = List.map (subst s) l
+and subst_decl s (id, exp) = (id, subst s exp)
+and subst_case s (key, case) = (key, subst s case)
+and subst_strcase s (key, case) = (key, subst s case)
+and subst_opt s = function
+ | None -> None
+ | Some e -> Some (subst s e)
+
let rec map f lam =
let lam =
Lvar var' when Ident.same var var' -> body
| _ -> Llet(str, Pgenval, var, exp, body)
-and commute_comparison = function
-| Ceq -> Ceq| Cneq -> Cneq
-| Clt -> Cgt | Cle -> Cge
-| Cgt -> Clt | Cge -> Cle
-
-and negate_comparison = function
-| Ceq -> Cneq| Cneq -> Ceq
-| Clt -> Cge | Cle -> Cgt
-| Cgt -> Cle | Cge -> Clt
+let negate_integer_comparison = function
+ | Ceq -> Cne
+ | Cne -> Ceq
+ | Clt -> Cge
+ | Cle -> Cgt
+ | Cgt -> Cle
+ | Cge -> Clt
+
+let swap_integer_comparison = function
+ | Ceq -> Ceq
+ | Cne -> Cne
+ | Clt -> Cgt
+ | Cle -> Cge
+ | Cgt -> Clt
+ | Cge -> Cle
+
+let negate_float_comparison = function
+ | CFeq -> CFneq
+ | CFneq -> CFeq
+ | CFlt -> CFnlt
+ | CFnlt -> CFlt
+ | CFgt -> CFngt
+ | CFngt -> CFgt
+ | CFle -> CFnle
+ | CFnle -> CFle
+ | CFge -> CFnge
+ | CFnge -> CFge
+
+let swap_float_comparison = function
+ | CFeq -> CFeq
+ | CFneq -> CFneq
+ | CFlt -> CFgt
+ | CFnlt -> CFngt
+ | CFle -> CFge
+ | CFnle -> CFnge
+ | CFgt -> CFlt
+ | CFngt -> CFnlt
+ | CFge -> CFle
+ | CFnge -> CFnle
let raise_kind = function
| Raise_regular -> "raise"
| Raise_reraise -> "reraise"
| Raise_notrace -> "raise_notrace"
-let lam_of_loc kind loc =
- let loc_start = loc.Location.loc_start in
- let (file, lnum, cnum) = Location.get_pos_info loc_start in
- let enum = loc.Location.loc_end.Lexing.pos_cnum -
- loc_start.Lexing.pos_cnum + cnum in
- match kind with
- | Loc_POS ->
- Lconst (Const_block (0, [
- Const_immstring file;
- Const_base (Const_int lnum);
- Const_base (Const_int cnum);
- Const_base (Const_int enum);
- ]))
- | Loc_FILE -> Lconst (Const_immstring file)
- | Loc_MODULE ->
- let filename = Filename.basename file in
- let name = Env.get_unit_name () in
- let module_name = if name = "" then "//"^filename^"//" else name in
- Lconst (Const_immstring module_name)
- | Loc_LOC ->
- let loc = Printf.sprintf "File %S, line %d, characters %d-%d"
- file lnum cnum enum in
- Lconst (Const_immstring loc)
- | Loc_LINE -> Lconst (Const_base (Const_int lnum))
-
let merge_inline_attributes attr1 attr2 =
match attr1, attr2 with
| Default_inline, _ -> Some attr2
| Ostype_cygwin
| Backend_type
-type loc_kind =
- | Loc_FILE
- | Loc_LINE
- | Loc_MODULE
- | Loc_LOC
- | Loc_POS
-
type immediate_or_pointer =
| Immediate
| Pointer
| Pignore
| Prevapply
| Pdirapply
- | Ploc of loc_kind
(* Globals *)
| Pgetglobal of Ident.t
| Psetglobal of Ident.t
| Pfloatfield of int
| Psetfloatfield of int * initialization_or_assignment
| Pduprecord of Types.record_representation * int
- (* Force lazy values *)
- | Plazyforce
(* External call *)
| Pccall of Primitive.description
(* Exceptions *)
| Pdivint of is_safe | Pmodint of is_safe
| Pandint | Porint | Pxorint
| Plslint | Plsrint | Pasrint
- | Pintcomp of comparison
+ | Pintcomp of integer_comparison
| Poffsetint of int
| Poffsetref of int
(* Float operations *)
| Pintoffloat | Pfloatofint
| Pnegfloat | Pabsfloat
| Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
- | Pfloatcomp of comparison
+ | Pfloatcomp of float_comparison
(* String operations *)
| Pstringlength | Pstringrefu | Pstringrefs
| Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
| Pisint
(* Test if the (integer) argument is outside an interval *)
| Pisout
- (* Bitvect operations *)
- | Pbittest
(* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
| Pbintofint of boxed_integer
| Pintofbint of boxed_integer
| Plslbint of boxed_integer
| Plsrbint of boxed_integer
| Pasrbint of boxed_integer
- | Pbintcomp of boxed_integer * comparison
+ | Pbintcomp of boxed_integer * integer_comparison
(* Operations on big arrays: (unsafe, #dimensions, kind, layout) *)
| Pbigarrayref of bool * int * bigarray_kind * bigarray_layout
| Pbigarrayset of bool * int * bigarray_kind * bigarray_layout
| Pstring_load_16 of bool
| Pstring_load_32 of bool
| Pstring_load_64 of bool
- | Pstring_set_16 of bool
- | Pstring_set_32 of bool
- | Pstring_set_64 of bool
+ | Pbytes_load_16 of bool
+ | Pbytes_load_32 of bool
+ | Pbytes_load_64 of bool
+ | Pbytes_set_16 of bool
+ | Pbytes_set_32 of bool
+ | Pbytes_set_64 of bool
(* load/set 16,32,64 bits from a
(char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
| Pbigstring_load_16 of bool
(* Inhibition of optimisation *)
| Popaque
-and comparison =
- Ceq | Cneq | Clt | Cgt | Cle | Cge
+and integer_comparison =
+ Ceq | Cne | Clt | Cgt | Cle | Cge
+
+and float_comparison =
+ CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge
and array_kind =
Pgenarray | Paddrarray | Pintarray | Pfloatarray
val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda
val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda
-val iter: (lambda -> unit) -> lambda -> unit
-module IdentSet: Set.S with type elt = Ident.t
-val free_variables: lambda -> IdentSet.t
-val free_methods: lambda -> IdentSet.t
+val iter_head_constructor: (lambda -> unit) -> lambda -> unit
+(** [iter_head_constructor f lam] apply [f] to only the first level of
+ sub expressions of [lam]. It does not recursively traverse the
+ expression. *)
+
+val free_variables: lambda -> Ident.Set.t
val transl_normal_path: Path.t -> lambda (* Path.t is already normal *)
val transl_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
val make_sequence: ('a -> lambda) -> 'a list -> lambda
-val subst_lambda: lambda Ident.tbl -> lambda -> lambda
+val subst: lambda Ident.Map.t -> lambda -> lambda
+(** Apply a substitution to a lambda-term.
+ Assumes that the image of the substitution is out of reach
+ of the bound variables of the lambda-term (no capture). *)
+
val map : (lambda -> lambda) -> lambda -> lambda
val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda
-val commute_comparison : comparison -> comparison
-val negate_comparison : comparison -> comparison
+val negate_integer_comparison : integer_comparison -> integer_comparison
+val swap_integer_comparison : integer_comparison -> integer_comparison
+
+val negate_float_comparison : float_comparison -> float_comparison
+val swap_float_comparison : float_comparison -> float_comparison
val default_function_attribute : function_attribute
val default_stub_attribute : function_attribute
(* Get a new static failure ident *)
val next_raise_count : unit -> int
-val next_negative_raise_count : unit -> int
- (* Negative raise counts are used to compile 'match ... with
- exception x -> ...'. This disabled some simplifications
- performed by the Simplif module that assume that static raises
- are in tail position in their handler. *)
val staticfail : lambda (* Anticipated static failure *)
val patch_guarded : lambda -> lambda -> lambda
val raise_kind: raise_kind -> string
-val lam_of_loc : loc_kind -> Location.t -> lambda
val merge_inline_attributes
: inline_attribute
open Lambda
open Parmatch
open Printf
+open Printpat
let dbg = false
Printlambda.lambda Format.str_formatter lam ;
Format.flush_str_formatter ()
+let all_record_args lbls = match lbls with
+| (_,{lbl_all=lbl_all},_)::_ ->
+ let t =
+ Array.map
+ (fun lbl -> mknoloc (Longident.Lident "?temp?"), lbl,omega)
+ lbl_all in
+ List.iter
+ (fun ((_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x)
+ lbls ;
+ Array.to_list t
+| _ -> fatal_error "Parmatch.all_record_args"
+
type matrix = pattern list list
let add_omega_column pss = List.map (fun ps -> omega::ps) pss
List.iter
(fun {left=left ; right=right} ->
prerr_string "LEFT:" ;
- pretty_line left ;
+ pretty_line Format.err_formatter left ;
prerr_string " RIGHT:" ;
- pretty_line right ;
+ pretty_line Format.err_formatter right ;
prerr_endline "")
ctx
end
| [] -> []
| _ ->
- pretty_matrix pss ;
+ pretty_matrix Format.err_formatter pss ;
fatal_error "Matching.filter_matrix" in
filter_rec pss
(fun (ps,_l) ->
List.iter
(fun p ->
- Parmatch.top_pretty Format.str_formatter p ;
+ top_pretty Format.str_formatter p ;
prerr_string " " ;
prerr_string (Format.flush_str_formatter ()))
ps ;
List.iter
(fun (pss,i) ->
Printf.fprintf stderr "Matrix for %d\n" i ;
- pretty_matrix pss)
+ pretty_matrix Format.err_formatter pss)
def ;
prerr_endline "+++++++++++++++++++++"
| PmOr x ->
prerr_endline "++++ OR ++++" ;
pretty_pm x.body ;
- pretty_matrix x.or_matrix ;
+ pretty_matrix Format.err_formatter x.or_matrix ;
List.iter
(fun (_,i,_,pm) ->
eprintf "++ Handler %d ++\n" i ;
(* Or-pattern expansion, variables are a complication w.r.t. the article *)
let rec extract_vars r p = match p.pat_desc with
-| Tpat_var (id, _) -> IdentSet.add id r
+| Tpat_var (id, _) -> Ident.Set.add id r
| Tpat_alias (p, id,_ ) ->
- extract_vars (IdentSet.add id r) p
+ extract_vars (Ident.Set.add id r) p
| Tpat_tuple pats ->
List.fold_left extract_vars r pats
| Tpat_record (lpats,_) ->
let pm_free_variables {cases=cases} =
List.fold_right
- (fun (_,act) r -> IdentSet.union (free_variables act) r)
- cases IdentSet.empty
+ (fun (_,act) r -> Ident.Set.union (free_variables act) r)
+ cases Ident.Set.empty
(* Basic grouping predicates *)
if is_or q then begin
if may_compat p q then
if
- IdentSet.is_empty (extract_vars IdentSet.empty p) &&
- IdentSet.is_empty (extract_vars IdentSet.empty q) &&
+ Ident.Set.is_empty (extract_vars Ident.Set.empty p) &&
+ Ident.Set.is_empty (extract_vars Ident.Set.empty q) &&
equiv_pat p q
then (* attempt insert, for equivalent orpats with no variables *)
let _, not_e = get_equiv q rem in
args = (match args with _::r -> r | _ -> assert false) ;
default = default_compat orp def} in
let vars =
- IdentSet.elements
- (IdentSet.inter
- (extract_vars IdentSet.empty orp)
+ Ident.Set.elements
+ (Ident.Set.inter
+ (extract_vars Ident.Set.empty orp)
(pm_free_variables orpm)) in
let or_num = next_raise_count () in
let new_patl = Parmatch.omega_list patl in
let d =
match d with
| None -> None
- | Some d -> Some (store.Switch.act_store_shared d) in
+ | Some d -> Some (store.Switch.act_store_shared () d) in
(* Store all other actions *)
let sw =
- List.map (fun (cst,act) -> cst,store.Switch.act_store act) sw in
+ List.map (fun (cst,act) -> cst,store.Switch.act_store () act) sw in
(* Retrieve all actions, including potential default *)
let acts = store.Switch.act_get_shared () in
type primitive = Lambda.primitive
let eqint = Pintcomp Ceq
- let neint = Pintcomp Cneq
+ let neint = Pintcomp Cne
let leint = Pintcomp Cle
let ltint = Pintcomp Clt
let geint = Pintcomp Cge
| None -> None
| Some fail ->
(* Fail is translated to exit, whatever happens *)
- Some (store.Switch.act_store_shared fail) in
+ Some (store.Switch.act_store_shared () fail) in
let consts =
List.map
- (fun (i,e) -> i,store.Switch.act_store e)
+ (fun (i,e) -> i,store.Switch.act_store () e)
sw.sw_consts
and blocks =
List.map
- (fun (i,e) -> i,store.Switch.act_store e)
+ (fun (i,e) -> i,store.Switch.act_store () e)
sw.sw_blocks in
let acts = store.Switch.act_get_shared () in
let hs,handle_shared = handle_shared () in
let do_store _tag act =
- let i = store.act_store act in
+ let i = store.act_store () act in
(*
eprintf "STORE [%s] %i %s\n" tag i (string_of_lam act) ;
*)
| [] ->
[cur_low, cur_high, cur_act]
| (i,act)::rem ->
- let act_index = store.act_store act in
+ let act_index = store.act_store () act in
if act_index = cur_act then
i_rec cur_low i cur_act rem
else
cases (cf. switch.ml, make_switch).
Hence, this action will be shared *)
if some_hole rem then
- store.act_store_shared act
+ store.act_store_shared () act
else
- store.act_store act in
+ store.act_store () act in
assert (act_index = 0) ;
i_rec i i act_index rem
| _ -> assert false in
| Const_float _ ->
make_test_sequence loc
fail
- (Pfloatcomp Cneq) (Pfloatcomp Clt)
+ (Pfloatcomp CFneq) (Pfloatcomp CFlt)
arg const_lambda_list
| Const_int32 _ ->
make_test_sequence loc
fail
- (Pbintcomp(Pint32, Cneq)) (Pbintcomp(Pint32, Clt))
+ (Pbintcomp(Pint32, Cne)) (Pbintcomp(Pint32, Clt))
arg const_lambda_list
| Const_int64 _ ->
make_test_sequence loc
fail
- (Pbintcomp(Pint64, Cneq)) (Pbintcomp(Pint64, Clt))
+ (Pbintcomp(Pint64, Cne)) (Pbintcomp(Pint64, Clt))
arg const_lambda_list
| Const_nativeint _ ->
make_test_sequence loc
fail
- (Pbintcomp(Pnativeint, Cneq)) (Pbintcomp(Pnativeint, Clt))
+ (Pbintcomp(Pnativeint, Cne)) (Pbintcomp(Pnativeint, Clt))
arg const_lambda_list
in lambda1,jumps_union local_jumps total
| Kgetvectitem -> fprintf ppf "\tgetvectitem"
| Ksetvectitem -> fprintf ppf "\tsetvectitem"
| Kgetstringchar -> fprintf ppf "\tgetstringchar"
- | Ksetstringchar -> fprintf ppf "\tsetstringchar"
+ | Kgetbyteschar -> fprintf ppf "\tgetbyteschar"
+ | Ksetbyteschar -> fprintf ppf "\tsetbyteschar"
| Kbranch lbl -> fprintf ppf "\tbranch L%i" lbl
| Kbranchif lbl -> fprintf ppf "\tbranchif L%i" lbl
| Kbranchifnot lbl -> fprintf ppf "\tbranchifnot L%i" lbl
| Klsrint -> fprintf ppf "\tlsrint"
| Kasrint -> fprintf ppf "\tasrint"
| Kintcomp Ceq -> fprintf ppf "\teqint"
- | Kintcomp Cneq -> fprintf ppf "\tneqint"
+ | Kintcomp Cne -> fprintf ppf "\tneqint"
| Kintcomp Clt -> fprintf ppf "\tltint"
| Kintcomp Cgt -> fprintf ppf "\tgtint"
| Kintcomp Cle -> fprintf ppf "\tleint"
| Record_extension -> fprintf ppf "ext"
;;
-let string_of_loc_kind = function
- | Loc_FILE -> "loc_FILE"
- | Loc_LINE -> "loc_LINE"
- | Loc_MODULE -> "loc_MODULE"
- | Loc_POS -> "loc_POS"
- | Loc_LOC -> "loc_LOC"
-
let block_shape ppf shape = match shape with
| None | Some [] -> ()
| Some l when List.for_all ((=) Pgenval) l -> ()
t;
Format.fprintf ppf ")"
+let integer_comparison ppf = function
+ | Ceq -> fprintf ppf "=="
+ | Cne -> fprintf ppf "!="
+ | Clt -> fprintf ppf "<"
+ | Cle -> fprintf ppf "<="
+ | Cgt -> fprintf ppf ">"
+ | Cge -> fprintf ppf ">="
+
+let float_comparison ppf = function
+ | CFeq -> fprintf ppf "==."
+ | CFneq -> fprintf ppf "!=."
+ | CFlt -> fprintf ppf "<."
+ | CFnlt -> fprintf ppf "!<."
+ | CFle -> fprintf ppf "<=."
+ | CFnle -> fprintf ppf "!<=."
+ | CFgt -> fprintf ppf ">."
+ | CFngt -> fprintf ppf "!>."
+ | CFge -> fprintf ppf ">=."
+ | CFnge -> fprintf ppf "!>=."
+
let primitive ppf = function
| Pidentity -> fprintf ppf "id"
| Pbytes_to_string -> fprintf ppf "bytes_to_string"
| Pignore -> fprintf ppf "ignore"
| Prevapply -> fprintf ppf "revapply"
| Pdirapply -> fprintf ppf "dirapply"
- | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind)
| Pgetglobal id -> fprintf ppf "global %a" Ident.print id
| Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
| Pmakeblock(tag, Immutable, shape) ->
in
fprintf ppf "setfloatfield%s %i" init n
| Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size
- | Plazyforce -> fprintf ppf "force"
| Pccall p -> fprintf ppf "%s" p.prim_name
| Praise k -> fprintf ppf "%s" (Lambda.raise_kind k)
| Psequand -> fprintf ppf "&&"
| Plslint -> fprintf ppf "lsl"
| Plsrint -> fprintf ppf "lsr"
| Pasrint -> fprintf ppf "asr"
- | Pintcomp(Ceq) -> fprintf ppf "=="
- | Pintcomp(Cneq) -> fprintf ppf "!="
- | Pintcomp(Clt) -> fprintf ppf "<"
- | Pintcomp(Cle) -> fprintf ppf "<="
- | Pintcomp(Cgt) -> fprintf ppf ">"
- | Pintcomp(Cge) -> fprintf ppf ">="
+ | Pintcomp(cmp) -> integer_comparison ppf cmp
| Poffsetint n -> fprintf ppf "%i+" n
| Poffsetref n -> fprintf ppf "+:=%i"n
| Pintoffloat -> fprintf ppf "int_of_float"
| Psubfloat -> fprintf ppf "-."
| Pmulfloat -> fprintf ppf "*."
| Pdivfloat -> fprintf ppf "/."
- | Pfloatcomp(Ceq) -> fprintf ppf "==."
- | Pfloatcomp(Cneq) -> fprintf ppf "!=."
- | Pfloatcomp(Clt) -> fprintf ppf "<."
- | Pfloatcomp(Cle) -> fprintf ppf "<=."
- | Pfloatcomp(Cgt) -> fprintf ppf ">."
- | Pfloatcomp(Cge) -> fprintf ppf ">=."
+ | Pfloatcomp(cmp) -> float_comparison ppf cmp
| Pstringlength -> fprintf ppf "string.length"
| Pstringrefu -> fprintf ppf "string.unsafe_get"
| Pstringrefs -> fprintf ppf "string.get"
fprintf ppf "sys.constant_%s" const_name
| Pisint -> fprintf ppf "isint"
| Pisout -> fprintf ppf "isout"
- | Pbittest -> fprintf ppf "testbit"
| Pbintofint bi -> print_boxed_integer "of_int" ppf bi
| Pintofbint bi -> print_boxed_integer "to_int" ppf bi
| Pcvtbint (bi1, bi2) -> print_boxed_integer_conversion ppf bi1 bi2
| Plsrbint bi -> print_boxed_integer "lsr" ppf bi
| Pasrbint bi -> print_boxed_integer "asr" ppf bi
| Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi
- | Pbintcomp(bi, Cneq) -> print_boxed_integer "!=" ppf bi
+ | Pbintcomp(bi, Cne) -> print_boxed_integer "!=" ppf bi
| Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi
| Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi
| Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi
| Pstring_load_64(unsafe) ->
if unsafe then fprintf ppf "string.unsafe_get64"
else fprintf ppf "string.get64"
- | Pstring_set_16(unsafe) ->
- if unsafe then fprintf ppf "string.unsafe_set16"
- else fprintf ppf "string.set16"
- | Pstring_set_32(unsafe) ->
- if unsafe then fprintf ppf "string.unsafe_set32"
- else fprintf ppf "string.set32"
- | Pstring_set_64(unsafe) ->
- if unsafe then fprintf ppf "string.unsafe_set64"
- else fprintf ppf "string.set64"
+ | Pbytes_load_16(unsafe) ->
+ if unsafe then fprintf ppf "bytes.unsafe_get16"
+ else fprintf ppf "bytes.get16"
+ | Pbytes_load_32(unsafe) ->
+ if unsafe then fprintf ppf "bytes.unsafe_get32"
+ else fprintf ppf "bytes.get32"
+ | Pbytes_load_64(unsafe) ->
+ if unsafe then fprintf ppf "bytes.unsafe_get64"
+ else fprintf ppf "bytes.get64"
+ | Pbytes_set_16(unsafe) ->
+ if unsafe then fprintf ppf "bytes.unsafe_set16"
+ else fprintf ppf "bytes.set16"
+ | Pbytes_set_32(unsafe) ->
+ if unsafe then fprintf ppf "bytes.unsafe_set32"
+ else fprintf ppf "bytes.set32"
+ | Pbytes_set_64(unsafe) ->
+ if unsafe then fprintf ppf "bytes.unsafe_set64"
+ else fprintf ppf "bytes.set64"
| Pbigstring_load_16(unsafe) ->
if unsafe then fprintf ppf "bigarray.array1.unsafe_get16"
else fprintf ppf "bigarray.array1.get16"
| Pignore -> "Pignore"
| Prevapply -> "Prevapply"
| Pdirapply -> "Pdirapply"
- | Ploc _ -> "Ploc"
| Pgetglobal _ -> "Pgetglobal"
| Psetglobal _ -> "Psetglobal"
| Pmakeblock _ -> "Pmakeblock"
| Pfloatfield _ -> "Pfloatfield"
| Psetfloatfield _ -> "Psetfloatfield"
| Pduprecord _ -> "Pduprecord"
- | Plazyforce -> "Plazyforce"
| Pccall _ -> "Pccall"
| Praise _ -> "Praise"
| Psequand -> "Psequand"
| Pctconst _ -> "Pctconst"
| Pisint -> "Pisint"
| Pisout -> "Pisout"
- | Pbittest -> "Pbittest"
| Pbintofint _ -> "Pbintofint"
| Pintofbint _ -> "Pintofbint"
| Pcvtbint _ -> "Pcvtbint"
| Pstring_load_16 _ -> "Pstring_load_16"
| Pstring_load_32 _ -> "Pstring_load_32"
| Pstring_load_64 _ -> "Pstring_load_64"
- | Pstring_set_16 _ -> "Pstring_set_16"
- | Pstring_set_32 _ -> "Pstring_set_32"
- | Pstring_set_64 _ -> "Pstring_set_64"
+ | Pbytes_load_16 _ -> "Pbytes_load_16"
+ | Pbytes_load_32 _ -> "Pbytes_load_32"
+ | Pbytes_load_64 _ -> "Pbytes_load_64"
+ | Pbytes_set_16 _ -> "Pbytes_set_16"
+ | Pbytes_set_32 _ -> "Pbytes_set_32"
+ | Pbytes_set_64 _ -> "Pbytes_set_64"
| Pbigstring_load_16 _ -> "Pbigstring_load_16"
| Pbigstring_load_32 _ -> "Pbigstring_load_32"
| Pbigstring_load_64 _ -> "Pbigstring_load_64"
let for_primitive (prim : Lambda.primitive) =
match prim with
- | Pignore | Pidentity | Pbytes_to_string | Pbytes_of_string ->
+ | Pignore | Pidentity ->
+ No_effects, No_coeffects
+ | Pbytes_to_string | Pbytes_of_string ->
No_effects, No_coeffects
| Pmakeblock _
| Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects
( "caml_format_float" | "caml_format_int" | "caml_int32_format"
| "caml_nativeint_format" | "caml_int64_format" ) } ->
No_effects, No_coeffects
- | Plazyforce
| Pccall _ -> Arbitrary_effects, Has_coeffects
| Praise _ -> Arbitrary_effects, No_coeffects
| Pnot
No_effects, Has_coeffects (* That old chestnut: [Obj.truncate]. *)
| Pisint
| Pisout
- | Pbittest
| Pbintofint _
| Pintofbint _
| Pcvtbint _
| Pstring_load_16 true
| Pstring_load_32 true
| Pstring_load_64 true
+ | Pbytes_load_16 true
+ | Pbytes_load_32 true
+ | Pbytes_load_64 true
| Pbigarrayref (true, _, _, _)
| Pbigstring_load_16 true
| Pbigstring_load_32 true
| Pstring_load_16 false
| Pstring_load_32 false
| Pstring_load_64 false
+ | Pbytes_load_16 false
+ | Pbytes_load_32 false
+ | Pbytes_load_64 false
| Pbigarrayref (false, _, _, _)
| Pbigstring_load_16 false
| Pbigstring_load_32 false
| Parraysets _
| Pbytessetu
| Pbytessets
- | Pstring_set_16 _
- | Pstring_set_32 _
- | Pstring_set_64 _
+ | Pbytes_set_16 _
+ | Pbytes_set_32 _
+ | Pbytes_set_64 _
| Pbigarrayset _
| Pbigstring_set_16 _
| Pbigstring_set_32 _
| Pbbswap _ -> No_effects, No_coeffects
| Pint_as_pointer -> No_effects, No_coeffects
| Popaque -> Arbitrary_effects, Has_coeffects
- | Ploc _ ->
- (* Removed by [Translcore]. *)
- No_effects, No_coeffects
| Prevapply
| Pdirapply ->
(* Removed by [Simplif], but there is no reason to prevent using
Lapply{ap with ap_func = eliminate_ref id ap.ap_func;
ap_args = List.map (eliminate_ref id) ap.ap_args}
| Lfunction _ as lam ->
- if IdentSet.mem id (free_variables lam)
+ if Ident.Set.mem id (free_variables lam)
then raise Real_reference
else lam
| Llet(str, kind, v, e1, e2) ->
(* Simplification of exits *)
+type exit = {
+ mutable count: int;
+ mutable max_depth: int;
+}
+
let simplify_exits lam =
(* Count occurrences of (exit n ...) statements *)
let exits = Hashtbl.create 17 in
- let count_exit i =
- try
- !(Hashtbl.find exits i)
- with
- | Not_found -> 0
+ let try_depth = ref 0 in
- and incr_exit i =
- try
- incr (Hashtbl.find exits i)
- with
- | Not_found -> Hashtbl.add exits i (ref 1) in
+ let get_exit i =
+ try Hashtbl.find exits i
+ with Not_found -> {count = 0; max_depth = 0}
+
+ and incr_exit i nb d =
+ match Hashtbl.find_opt exits i with
+ | Some r ->
+ r.count <- r.count + nb;
+ r.max_depth <- max r.max_depth d
+ | None ->
+ let r = {count = nb; max_depth = d} in
+ Hashtbl.add exits i r
+ in
let rec count = function
| (Lvar _| Lconst _) -> ()
| []|[_] -> count d
| _ -> count d; count d (* default will get replicated *)
end
- | Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls
+ | Lstaticraise (i,ls) -> incr_exit i 1 !try_depth; List.iter count ls
| Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) ->
(* i will be replaced by j in l1, so each occurrence of i in l1
increases j's ref count *)
count l1 ;
- let ic = count_exit i in
- begin try
- let r = Hashtbl.find exits j in r := !r + ic
- with
- | Not_found ->
- Hashtbl.add exits j (ref ic)
- end
+ let ic = get_exit i in
+ incr_exit j ic.count (max !try_depth ic.max_depth)
| Lstaticcatch(l1, (i,_), l2) ->
count l1;
(* If l1 does not contain (exit i),
l2 will be removed, so don't count its exits *)
- if count_exit i > 0 then
+ if (get_exit i).count > 0 then
count l2
- | Ltrywith(l1, _v, l2) -> count l1; count l2
+ | Ltrywith(l1, _v, l2) -> incr try_depth; count l1; decr try_depth; count l2
| Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3
| Lsequence(l1, l2) -> count l1; count l2
| Lwhile(l1, l2) -> count l1; count l2
end
in
count lam;
+ assert(!try_depth = 0);
(*
Second pass simplify ``catch body with (i ...) handler''
let ys = List.map Ident.rename xs in
let env =
List.fold_right2
- (fun x y t -> Ident.add x (Lvar y) t)
- xs ys Ident.empty in
+ (fun x y t -> Ident.Map.add x (Lvar y) t)
+ xs ys Ident.Map.empty in
List.fold_right2
(fun y l r -> Llet (Alias, Pgenval, y, l, r))
- ys ls (Lambda.subst_lambda env handler)
+ ys ls (Lambda.subst env handler)
with
| Not_found -> Lstaticraise (i,ls)
end
Hashtbl.add subst i ([],simplif l2) ;
simplif l1
| Lstaticcatch (l1,(i,xs),l2) ->
- begin match count_exit i with
- | 0 -> simplif l1
- | 1 when i >= 0 ->
- Hashtbl.add subst i (xs,simplif l2) ;
- simplif l1
- | _ ->
- Lstaticcatch (simplif l1, (i,xs), simplif l2)
- end
- | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2)
+ let {count; max_depth} = get_exit i in
+ if count = 0 then
+ (* Discard staticcatch: not matching exit *)
+ simplif l1
+ else if count = 1 && max_depth <= !try_depth then begin
+ (* Inline handler if there is a single occurrence and it is not
+ nested within an inner try..with *)
+ assert(max_depth = !try_depth);
+ Hashtbl.add subst i (xs,simplif l2);
+ simplif l1
+ end else
+ Lstaticcatch (simplif l1, (i,xs), simplif l2)
+ | Ltrywith(l1, v, l2) ->
+ incr try_depth;
+ let l1 = simplif l1 in
+ decr try_depth;
+ Ltrywith(l1, v, simplif l2)
| Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3)
| Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2)
| Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2)
| Lletrec (bindings, body) ->
List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings;
emit_tail_infos is_tail body
- | Lprim ((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _) ->
+ | Lprim (Pidentity, [arg], _) ->
+ emit_tail_infos is_tail arg
+ | Lprim ((Pbytes_to_string | Pbytes_of_string), [arg], _) ->
emit_tail_infos is_tail arg
| Lprim (Psequand, [arg1; arg2], _)
| Lprim (Psequor, [arg1; arg2], _) ->
(* Check that those *opt* identifiers don't appear in the remaining
body. This should not appear, but let's be on the safe side. *)
let fv = Lambda.free_variables body in
- List.iter (fun (id, _) -> if IdentSet.mem id fv then raise Exit) map;
+ List.iter (fun (id, _) -> if Ident.Set.mem id fv then raise Exit) map;
let inner_id = Ident.create (Ident.name fun_id ^ "_inner") in
let map_param p = try List.assoc p map with Not_found -> p in
let new_ids = List.map Ident.rename inner_params in
let subst = List.fold_left2
(fun s id new_id ->
- Ident.add id (Lvar new_id) s)
- Ident.empty inner_params new_ids
+ Ident.Map.add id (Lvar new_id) s)
+ Ident.Map.empty inner_params new_ids
in
- let body = Lambda.subst_lambda subst body in
+ let body = Lambda.subst subst body in
let inner_fun =
Lfunction { kind = Curried; params = new_ids; body; attr; loc; }
in
type 'a shared = Shared of 'a | Single of 'a
-type 'a t_store =
+type ('a, 'ctx) t_store =
{act_get : unit -> 'a array ;
act_get_shared : unit -> 'a shared array ;
- act_store : 'a -> int ;
- act_store_shared : 'a -> int ; }
+ act_store : 'ctx -> 'a -> int ;
+ act_store_shared : 'ctx -> 'a -> int ; }
exception Not_simple
val make_key : t -> key option
end
-module Store(A:Stored) = struct
+module type CtxStored = sig
+ include Stored
+ type context
+ val make_key : context -> t -> key option
+end
+
+module CtxStore(A:CtxStored) = struct
module AMap =
Map.Make(struct type t = A.key let compare = A.compare_key end)
st.next <- i+1 ;
i in
- let store mustshare act = match A.make_key act with
+ let store mustshare ctx act = match A.make_key ctx act with
| Some key ->
begin try
let (shared,i) = AMap.find key st.map in
act_get = get; act_get_shared = get_shared; }
end
+module Store(A:Stored) = struct
+ module Me =
+ CtxStore
+ (struct
+ include A
+ type context = unit
+ let make_key () = A.make_key
+ end)
+
+ let mk_store = Me.mk_store
+end
+
module type S =
type 'a shared = Shared of 'a | Single of 'a
-type 'a t_store =
+type ('a, 'ctx) t_store =
{act_get : unit -> 'a array ;
act_get_shared : unit -> 'a shared array ;
- act_store : 'a -> int ;
- act_store_shared : 'a -> int ; }
+ act_store : 'ctx -> 'a -> int ;
+ act_store_shared : 'ctx -> 'a -> int ; }
exception Not_simple
val make_key : t -> key option
end
+module type CtxStored = sig
+ include Stored
+ type context
+ val make_key : context -> t -> key option
+end
+
+module CtxStore(A:CtxStored) :
+ sig
+ val mk_store : unit -> (A.t, A.context) t_store
+ end
+
module Store(A:Stored) :
sig
- val mk_store : unit -> A.t t_store
+ val mk_store : unit -> (A.t, unit) t_store
end
(* Arguments to the Make functor *)
(int * int) ->
Arg.act ->
(int * int * int) array ->
- Arg.act t_store ->
+ (Arg.act, _) t_store ->
Arg.act
(* Output test sequence, sharing tracked *)
val test_sequence :
Arg.act ->
(int * int * int) array ->
- Arg.act t_store ->
+ (Arg.act, _) t_store ->
Arg.act
end
inlined, { e with exp_attributes }
let get_and_remove_inlined_attribute_on_module e =
- let attr, mod_attributes =
- find_attribute is_inlined_attribute e.mod_attributes
+ let rec get_and_remove mod_expr =
+ let attr, mod_attributes =
+ find_attribute is_inlined_attribute mod_expr.mod_attributes
+ in
+ let attr = parse_inline_attribute attr in
+ let attr, mod_desc =
+ match mod_expr.Typedtree.mod_desc with
+ | Tmod_constraint (me, mt, mtc, mc) ->
+ let inner_attr, me = get_and_remove me in
+ let attr =
+ match attr with
+ | Always_inline | Never_inline | Unroll _ -> attr
+ | Default_inline -> inner_attr
+ in
+ attr, Tmod_constraint (me, mt, mtc, mc)
+ | md -> attr, md
+ in
+ attr, { mod_expr with mod_desc; mod_attributes }
in
- let inlined = parse_inline_attribute attr in
- inlined, { e with mod_attributes }
+ get_and_remove e
let get_and_remove_specialised_attribute e =
let attr, exp_attributes =
let rec get_class_meths cl =
match cl.cl_desc with
Tcl_structure cl ->
- Meths.fold (fun _ -> IdentSet.add) cl.cstr_meths IdentSet.empty
- | Tcl_ident _ -> IdentSet.empty
+ Meths.fold (fun _ -> Ident.Set.add) cl.cstr_meths Ident.Set.empty
+ | Tcl_ident _ -> Ident.Set.empty
| Tcl_fun (_, _, _, cl, _)
| Tcl_let (_, _, _, cl)
| Tcl_apply (cl, _)
| Lconst _ -> true
| Lfunction {kind = Curried; body} ->
let fv = free_variables body in
- List.for_all (fun x -> not (IdentSet.mem x fv)) local
+ List.for_all (fun x -> not (Ident.Set.mem x fv)) local
| p -> module_path p
let rec builtin_meths self env env2 body =
prerr_endline (String.concat " " (msg :: names))
*)
+let free_methods l =
+ let fv = ref Ident.Set.empty in
+ let rec free l =
+ Lambda.iter_head_constructor free l;
+ match l with
+ | Lsend(Self, Lvar meth, _, _, _) ->
+ fv := Ident.Set.add meth !fv
+ | Lsend _ -> ()
+ | Lfunction{params} ->
+ List.iter (fun param -> fv := Ident.Set.remove param !fv) params
+ | Llet(_str, _k, id, _arg, _body) ->
+ fv := Ident.Set.remove id !fv
+ | Lletrec(decl, _body) ->
+ List.iter (fun (id, _exp) -> fv := Ident.Set.remove id !fv) decl
+ | Lstaticcatch(_e1, (_,vars), _e2) ->
+ List.iter (fun id -> fv := Ident.Set.remove id !fv) vars
+ | Ltrywith(_e1, exn, _e2) ->
+ fv := Ident.Set.remove exn !fv
+ | Lfor(v, _e1, _e2, _dir, _e3) ->
+ fv := Ident.Set.remove v !fv
+ | Lassign _
+ | Lvar _ | Lconst _ | Lapply _
+ | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _
+ | Lifthenelse _ | Lsequence _ | Lwhile _
+ | Levent _ | Lifused _ -> ()
+ in free l; !fv
+
let transl_class ids cl_id pub_meths cl vflag =
(* First check if it is not only a rebind *)
let rebind = transl_class_rebind cl vflag in
let meth_ids = get_class_meths cl in
let subst env lam i0 new_ids' =
let fv = free_variables lam in
- (* prerr_ids "cl_id =" [cl_id]; prerr_ids "fv =" (IdentSet.elements fv); *)
- let fv = List.fold_right IdentSet.remove !new_ids' fv in
+ (* prerr_ids "cl_id =" [cl_id]; prerr_ids "fv =" (Ident.Set.elements fv); *)
+ let fv = List.fold_right Ident.Set.remove !new_ids' fv in
(* We need to handle method ids specially, as they do not appear
in the typing environment (PR#3576, PR#4560) *)
(* very hacky: we add and remove free method ids on the fly,
depending on the visit order... *)
method_ids :=
- IdentSet.diff (IdentSet.union (free_methods lam) !method_ids) meth_ids;
- (* prerr_ids "meth_ids =" (IdentSet.elements meth_ids);
- prerr_ids "method_ids =" (IdentSet.elements !method_ids); *)
- let new_ids = List.fold_right IdentSet.add new_ids !method_ids in
- let fv = IdentSet.inter fv new_ids in
- new_ids' := !new_ids' @ IdentSet.elements fv;
+ Ident.Set.diff (Ident.Set.union (free_methods lam) !method_ids) meth_ids;
+ (* prerr_ids "meth_ids =" (Ident.Set.elements meth_ids);
+ prerr_ids "method_ids =" (Ident.Set.elements !method_ids); *)
+ let new_ids = List.fold_right Ident.Set.add new_ids !method_ids in
+ let fv = Ident.Set.inter fv new_ids in
+ new_ids' := !new_ids' @ Ident.Set.elements fv;
(* prerr_ids "new_ids' =" !new_ids'; *)
let i = ref (i0-1) in
List.fold_left
(fun subst id ->
- incr i; Ident.add id (lfield env !i) subst)
- Ident.empty !new_ids'
+ incr i; Ident.Map.add id (lfield env !i) subst)
+ Ident.Map.empty !new_ids'
in
let new_ids_meths = ref [] in
let msubst arr = function
let env = Ident.create "env" in
let body' =
if new_ids = [] then body else
- subst_lambda (subst env body 0 new_ids_meths) body in
+ Lambda.subst (subst env body 0 new_ids_meths) body in
begin try
(* Doesn't seem to improve size for bytecode *)
(* if not !Clflags.native_code then raise Not_found; *)
builtin_meths [self] env env2 (lfunction args body')
with Not_found ->
[lfunction (self :: args)
- (if not (IdentSet.mem env (free_variables body')) then body' else
+ (if not (Ident.Set.mem env (free_variables body')) then body' else
Llet(Alias, Pgenval, env,
Lprim(Pfield_computed,
[Lvar self; Lvar env2],
and subst_env envs l lam =
if top then lam else
(* must be called only once! *)
- let lam = subst_lambda (subst env1 lam 1 new_ids_init) lam in
+ let lam = Lambda.subst (subst env1 lam 1 new_ids_init) lam in
Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0),
Llet(Alias, Pgenval, env1',
(if !new_ids_init = [] then Lvar env1 else lfield env1 0),
params = [cla]; body = cl_init}) in
Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init))
and lbody fv =
- if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
+ if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then
mkappl (oo_prim "make_class",[transl_meth_list pub_meths;
Lvar class_init])
else
type error =
Free_super_var
- | Unknown_builtin_primitive of string
| Unreachable_reached
exception Error of Location.t * error
Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false)
let transl_extension_constructor env path ext =
+ let path =
+ Stdlib.Option.map (Printtyp.rewrite_double_underscore_paths env) path
+ in
let name =
match path, !Clflags.for_package with
None, _ -> Ident.name ext.ext_id
| Text_rebind(path, _lid) ->
transl_extension_path ~loc env path
-(* Translation of primitives *)
-
-let comparisons_table = create_hashtable 11 [
- "%equal",
- (Pccall(Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true),
- Pintcomp Ceq,
- Pfloatcomp Ceq,
- Pccall(Primitive.simple ~name:"caml_string_equal" ~arity:2
- ~alloc:false),
- Pccall(Primitive.simple ~name:"caml_bytes_equal" ~arity:2
- ~alloc:false),
- Pbintcomp(Pnativeint, Ceq),
- Pbintcomp(Pint32, Ceq),
- Pbintcomp(Pint64, Ceq),
- true);
- "%notequal",
- (Pccall(Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true),
- Pintcomp Cneq,
- Pfloatcomp Cneq,
- Pccall(Primitive.simple ~name:"caml_string_notequal" ~arity:2
- ~alloc:false),
- Pccall(Primitive.simple ~name:"caml_bytes_notequal" ~arity:2
- ~alloc:false),
- Pbintcomp(Pnativeint, Cneq),
- Pbintcomp(Pint32, Cneq),
- Pbintcomp(Pint64, Cneq),
- true);
- "%lessthan",
- (Pccall(Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true),
- Pintcomp Clt,
- Pfloatcomp Clt,
- Pccall(Primitive.simple ~name:"caml_string_lessthan" ~arity:2
- ~alloc:false),
- Pccall(Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2
- ~alloc:false),
- Pbintcomp(Pnativeint, Clt),
- Pbintcomp(Pint32, Clt),
- Pbintcomp(Pint64, Clt),
- false);
- "%greaterthan",
- (Pccall(Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true),
- Pintcomp Cgt,
- Pfloatcomp Cgt,
- Pccall(Primitive.simple ~name:"caml_string_greaterthan" ~arity:2
- ~alloc: false),
- Pccall(Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2
- ~alloc: false),
- Pbintcomp(Pnativeint, Cgt),
- Pbintcomp(Pint32, Cgt),
- Pbintcomp(Pint64, Cgt),
- false);
- "%lessequal",
- (Pccall(Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true),
- Pintcomp Cle,
- Pfloatcomp Cle,
- Pccall(Primitive.simple ~name:"caml_string_lessequal" ~arity:2
- ~alloc:false),
- Pccall(Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2
- ~alloc:false),
- Pbintcomp(Pnativeint, Cle),
- Pbintcomp(Pint32, Cle),
- Pbintcomp(Pint64, Cle),
- false);
- "%greaterequal",
- (Pccall(Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true),
- Pintcomp Cge,
- Pfloatcomp Cge,
- Pccall(Primitive.simple ~name:"caml_string_greaterequal" ~arity:2
- ~alloc:false),
- Pccall(Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2
- ~alloc:false),
- Pbintcomp(Pnativeint, Cge),
- Pbintcomp(Pint32, Cge),
- Pbintcomp(Pint64, Cge),
- false);
- "%compare",
- let unboxed_compare name native_repr =
- Pccall( Primitive.make ~name ~alloc:false
- ~native_name:(name^"_unboxed")
- ~native_repr_args:[native_repr;native_repr]
- ~native_repr_res:Untagged_int
- ) in
- (Pccall(Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true),
- (* Not unboxed since the comparison is done directly on tagged int *)
- Pccall(Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false),
- unboxed_compare "caml_float_compare" Unboxed_float,
- Pccall(Primitive.simple ~name:"caml_string_compare" ~arity:2
- ~alloc:false),
- Pccall(Primitive.simple ~name:"caml_bytes_compare" ~arity:2
- ~alloc:false),
- unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint),
- unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32),
- unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64),
- false)
-]
-
-let gen_array_kind =
- if Config.flat_float_array then Pgenarray else Paddrarray
-
-let primitives_table = create_hashtable 57 [
- "%identity", Pidentity;
- "%bytes_to_string", Pbytes_to_string;
- "%bytes_of_string", Pbytes_of_string;
- "%ignore", Pignore;
- "%revapply", Prevapply;
- "%apply", Pdirapply;
- "%loc_LOC", Ploc Loc_LOC;
- "%loc_FILE", Ploc Loc_FILE;
- "%loc_LINE", Ploc Loc_LINE;
- "%loc_POS", Ploc Loc_POS;
- "%loc_MODULE", Ploc Loc_MODULE;
- "%field0", Pfield 0;
- "%field1", Pfield 1;
- "%setfield0", Psetfield(0, Pointer, Assignment);
- "%makeblock", Pmakeblock(0, Immutable, None);
- "%makemutable", Pmakeblock(0, Mutable, None);
- "%raise", Praise Raise_regular;
- "%reraise", Praise Raise_reraise;
- "%raise_notrace", Praise Raise_notrace;
- "%sequand", Psequand;
- "%sequor", Psequor;
- "%boolnot", Pnot;
- "%big_endian", Pctconst Big_endian;
- "%backend_type", Pctconst Backend_type;
- "%word_size", Pctconst Word_size;
- "%int_size", Pctconst Int_size;
- "%max_wosize", Pctconst Max_wosize;
- "%ostype_unix", Pctconst Ostype_unix;
- "%ostype_win32", Pctconst Ostype_win32;
- "%ostype_cygwin", Pctconst Ostype_cygwin;
- "%negint", Pnegint;
- "%succint", Poffsetint 1;
- "%predint", Poffsetint(-1);
- "%addint", Paddint;
- "%subint", Psubint;
- "%mulint", Pmulint;
- "%divint", Pdivint Safe;
- "%modint", Pmodint Safe;
- "%andint", Pandint;
- "%orint", Porint;
- "%xorint", Pxorint;
- "%lslint", Plslint;
- "%lsrint", Plsrint;
- "%asrint", Pasrint;
- "%eq", Pintcomp Ceq;
- "%noteq", Pintcomp Cneq;
- "%ltint", Pintcomp Clt;
- "%leint", Pintcomp Cle;
- "%gtint", Pintcomp Cgt;
- "%geint", Pintcomp Cge;
- "%incr", Poffsetref(1);
- "%decr", Poffsetref(-1);
- "%intoffloat", Pintoffloat;
- "%floatofint", Pfloatofint;
- "%negfloat", Pnegfloat;
- "%absfloat", Pabsfloat;
- "%addfloat", Paddfloat;
- "%subfloat", Psubfloat;
- "%mulfloat", Pmulfloat;
- "%divfloat", Pdivfloat;
- "%eqfloat", Pfloatcomp Ceq;
- "%noteqfloat", Pfloatcomp Cneq;
- "%ltfloat", Pfloatcomp Clt;
- "%lefloat", Pfloatcomp Cle;
- "%gtfloat", Pfloatcomp Cgt;
- "%gefloat", Pfloatcomp Cge;
- "%string_length", Pstringlength;
- "%string_safe_get", Pstringrefs;
- "%string_safe_set", Pbytessets;
- "%string_unsafe_get", Pstringrefu;
- "%string_unsafe_set", Pbytessetu;
- "%bytes_length", Pbyteslength;
- "%bytes_safe_get", Pbytesrefs;
- "%bytes_safe_set", Pbytessets;
- "%bytes_unsafe_get", Pbytesrefu;
- "%bytes_unsafe_set", Pbytessetu;
- "%array_length", Parraylength gen_array_kind;
- "%array_safe_get", Parrayrefs gen_array_kind;
- "%array_safe_set", Parraysets gen_array_kind;
- "%array_unsafe_get", Parrayrefu gen_array_kind;
- "%array_unsafe_set", Parraysetu gen_array_kind;
- "%obj_size", Parraylength gen_array_kind;
- "%obj_field", Parrayrefu gen_array_kind;
- "%obj_set_field", Parraysetu gen_array_kind;
- "%floatarray_length", Parraylength Pfloatarray;
- "%floatarray_safe_get", Parrayrefs Pfloatarray;
- "%floatarray_safe_set", Parraysets Pfloatarray;
- "%floatarray_unsafe_get", Parrayrefu Pfloatarray;
- "%floatarray_unsafe_set", Parraysetu Pfloatarray;
- "%obj_is_int", Pisint;
- "%lazy_force", Plazyforce;
- "%nativeint_of_int", Pbintofint Pnativeint;
- "%nativeint_to_int", Pintofbint Pnativeint;
- "%nativeint_neg", Pnegbint Pnativeint;
- "%nativeint_add", Paddbint Pnativeint;
- "%nativeint_sub", Psubbint Pnativeint;
- "%nativeint_mul", Pmulbint Pnativeint;
- "%nativeint_div", Pdivbint { size = Pnativeint; is_safe = Safe };
- "%nativeint_mod", Pmodbint { size = Pnativeint; is_safe = Safe };
- "%nativeint_and", Pandbint Pnativeint;
- "%nativeint_or", Porbint Pnativeint;
- "%nativeint_xor", Pxorbint Pnativeint;
- "%nativeint_lsl", Plslbint Pnativeint;
- "%nativeint_lsr", Plsrbint Pnativeint;
- "%nativeint_asr", Pasrbint Pnativeint;
- "%int32_of_int", Pbintofint Pint32;
- "%int32_to_int", Pintofbint Pint32;
- "%int32_neg", Pnegbint Pint32;
- "%int32_add", Paddbint Pint32;
- "%int32_sub", Psubbint Pint32;
- "%int32_mul", Pmulbint Pint32;
- "%int32_div", Pdivbint { size = Pint32; is_safe = Safe };
- "%int32_mod", Pmodbint { size = Pint32; is_safe = Safe };
- "%int32_and", Pandbint Pint32;
- "%int32_or", Porbint Pint32;
- "%int32_xor", Pxorbint Pint32;
- "%int32_lsl", Plslbint Pint32;
- "%int32_lsr", Plsrbint Pint32;
- "%int32_asr", Pasrbint Pint32;
- "%int64_of_int", Pbintofint Pint64;
- "%int64_to_int", Pintofbint Pint64;
- "%int64_neg", Pnegbint Pint64;
- "%int64_add", Paddbint Pint64;
- "%int64_sub", Psubbint Pint64;
- "%int64_mul", Pmulbint Pint64;
- "%int64_div", Pdivbint { size = Pint64; is_safe = Safe };
- "%int64_mod", Pmodbint { size = Pint64; is_safe = Safe };
- "%int64_and", Pandbint Pint64;
- "%int64_or", Porbint Pint64;
- "%int64_xor", Pxorbint Pint64;
- "%int64_lsl", Plslbint Pint64;
- "%int64_lsr", Plsrbint Pint64;
- "%int64_asr", Pasrbint Pint64;
- "%nativeint_of_int32", Pcvtbint(Pint32, Pnativeint);
- "%nativeint_to_int32", Pcvtbint(Pnativeint, Pint32);
- "%int64_of_int32", Pcvtbint(Pint32, Pint64);
- "%int64_to_int32", Pcvtbint(Pint64, Pint32);
- "%int64_of_nativeint", Pcvtbint(Pnativeint, Pint64);
- "%int64_to_nativeint", Pcvtbint(Pint64, Pnativeint);
- "%caml_ba_ref_1",
- Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
- "%caml_ba_ref_2",
- Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
- "%caml_ba_ref_3",
- Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
- "%caml_ba_set_1",
- Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
- "%caml_ba_set_2",
- Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
- "%caml_ba_set_3",
- Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
- "%caml_ba_unsafe_ref_1",
- Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
- "%caml_ba_unsafe_ref_2",
- Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
- "%caml_ba_unsafe_ref_3",
- Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
- "%caml_ba_unsafe_set_1",
- Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
- "%caml_ba_unsafe_set_2",
- Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
- "%caml_ba_unsafe_set_3",
- Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
- "%caml_ba_dim_1", Pbigarraydim(1);
- "%caml_ba_dim_2", Pbigarraydim(2);
- "%caml_ba_dim_3", Pbigarraydim(3);
- "%caml_string_get16", Pstring_load_16(false);
- "%caml_string_get16u", Pstring_load_16(true);
- "%caml_string_get32", Pstring_load_32(false);
- "%caml_string_get32u", Pstring_load_32(true);
- "%caml_string_get64", Pstring_load_64(false);
- "%caml_string_get64u", Pstring_load_64(true);
- "%caml_string_set16", Pstring_set_16(false);
- "%caml_string_set16u", Pstring_set_16(true);
- "%caml_string_set32", Pstring_set_32(false);
- "%caml_string_set32u", Pstring_set_32(true);
- "%caml_string_set64", Pstring_set_64(false);
- "%caml_string_set64u", Pstring_set_64(true);
- "%caml_bigstring_get16", Pbigstring_load_16(false);
- "%caml_bigstring_get16u", Pbigstring_load_16(true);
- "%caml_bigstring_get32", Pbigstring_load_32(false);
- "%caml_bigstring_get32u", Pbigstring_load_32(true);
- "%caml_bigstring_get64", Pbigstring_load_64(false);
- "%caml_bigstring_get64u", Pbigstring_load_64(true);
- "%caml_bigstring_set16", Pbigstring_set_16(false);
- "%caml_bigstring_set16u", Pbigstring_set_16(true);
- "%caml_bigstring_set32", Pbigstring_set_32(false);
- "%caml_bigstring_set32u", Pbigstring_set_32(true);
- "%caml_bigstring_set64", Pbigstring_set_64(false);
- "%caml_bigstring_set64u", Pbigstring_set_64(true);
- "%bswap16", Pbswap16;
- "%bswap_int32", Pbbswap(Pint32);
- "%bswap_int64", Pbbswap(Pint64);
- "%bswap_native", Pbbswap(Pnativeint);
- "%int_as_pointer", Pint_as_pointer;
- "%opaque", Popaque;
-]
-
-let find_primitive prim_name =
- Hashtbl.find primitives_table prim_name
-
-let prim_restore_raw_backtrace =
- Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false
-
-let specialize_comparison table env ty =
- let (gencomp, intcomp, floatcomp, stringcomp, bytescomp,
- nativeintcomp, int32comp, int64comp, _) = table in
- match () with
- | () when is_base_type env ty Predef.path_int
- || is_base_type env ty Predef.path_char
- || (maybe_pointer_type env ty = Immediate) -> intcomp
- | () when is_base_type env ty Predef.path_float -> floatcomp
- | () when is_base_type env ty Predef.path_string -> stringcomp
- | () when is_base_type env ty Predef.path_bytes -> bytescomp
- | () when is_base_type env ty Predef.path_nativeint -> nativeintcomp
- | () when is_base_type env ty Predef.path_int32 -> int32comp
- | () when is_base_type env ty Predef.path_int64 -> int64comp
- | () -> gencomp
-
-(* The following function computes the greatest lower bound in the
- semilattice of array kinds:
- gen
- / \
- addr float
- |
- int
- Note that the GLB is not guaranteed to exist, in which case we return
- our first argument instead of raising a fatal error because, although
- it cannot happen in a well-typed program, (ab)use of Obj.magic can
- probably trigger it.
-*)
-let glb_array_type t1 t2 =
- match t1, t2 with
- | Pfloatarray, (Paddrarray | Pintarray)
- | (Paddrarray | Pintarray), Pfloatarray -> t1
-
- | Pgenarray, x | x, Pgenarray -> x
- | Paddrarray, x | x, Paddrarray -> x
- | Pintarray, Pintarray -> Pintarray
- | Pfloatarray, Pfloatarray -> Pfloatarray
-
-(* Specialize a primitive from available type information,
- raise Not_found if primitive is unknown *)
-
-let specialize_primitive p env ty ~has_constant_constructor =
- try
- let table = Hashtbl.find comparisons_table p.prim_name in
- let (gencomp, intcomp, _, _, _, _, _, _, simplify_constant_constructor) =
- table in
- if has_constant_constructor && simplify_constant_constructor then
- intcomp
- else
- match is_function_type env ty with
- | Some (lhs,_rhs) -> specialize_comparison table env lhs
- | None -> gencomp
- with Not_found ->
- let p = find_primitive p.prim_name in
- (* Try strength reduction based on the type of the argument *)
- let params = match is_function_type env ty with
- | None -> []
- | Some (p1, rhs) -> match is_function_type env rhs with
- | None -> [p1]
- | Some (p2, _) -> [p1;p2]
- in
- match (p, params) with
- (Psetfield(n, _, init), [_p1; p2]) ->
- Psetfield(n, maybe_pointer_type env p2, init)
- | (Parraylength t, [p]) ->
- Parraylength(glb_array_type t (array_type_kind env p))
- | (Parrayrefu t, p1 :: _) ->
- Parrayrefu(glb_array_type t (array_type_kind env p1))
- | (Parraysetu t, p1 :: _) ->
- Parraysetu(glb_array_type t (array_type_kind env p1))
- | (Parrayrefs t, p1 :: _) ->
- Parrayrefs(glb_array_type t (array_type_kind env p1))
- | (Parraysets t, p1 :: _) ->
- Parraysets(glb_array_type t (array_type_kind env p1))
- | (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout),
- p1 :: _) ->
- let (k, l) = bigarray_type_kind_and_layout env p1 in
- Pbigarrayref(unsafe, n, k, l)
- | (Pbigarrayset(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout),
- p1 :: _) ->
- let (k, l) = bigarray_type_kind_and_layout env p1 in
- Pbigarrayset(unsafe, n, k, l)
- | (Pmakeblock(tag, mut, None), fields) ->
- let shape = List.map (Typeopt.value_kind env) fields in
- Pmakeblock(tag, mut, Some shape)
- | _ -> p
-
-(* Eta-expand a primitive *)
-
-let used_primitives = Hashtbl.create 7
-let add_used_primitive loc env path =
- match path with
- Some (Path.Pdot _ as path) ->
- let path = Env.normalize_path (Some loc) env path in
- let unit = Path.head path in
- if Ident.global unit && not (Hashtbl.mem used_primitives path)
- then Hashtbl.add used_primitives path loc
- | _ -> ()
-
-let transl_primitive loc p env ty path =
- let prim =
- try specialize_primitive p env ty ~has_constant_constructor:false
- with Not_found ->
- add_used_primitive loc env path;
- Pccall p
- in
- match prim with
- | Plazyforce ->
- let parm = Ident.create "prim" in
- Lfunction{kind = Curried; params = [parm];
- body = Matching.inline_lazy_force (Lvar parm) Location.none;
- loc = loc;
- attr = default_stub_attribute }
- | Ploc kind ->
- let lam = lam_of_loc kind loc in
- begin match p.prim_arity with
- | 0 -> lam
- | 1 -> (* TODO: we should issue a warning ? *)
- let param = Ident.create "prim" in
- Lfunction{kind = Curried; params = [param];
- attr = default_stub_attribute;
- loc = loc;
- body = Lprim(Pmakeblock(0, Immutable, None),
- [lam; Lvar param], loc)}
- | _ -> assert false
- end
- | _ ->
- let rec make_params n =
- if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in
- let params = make_params p.prim_arity in
- Lfunction{ kind = Curried; params;
- attr = default_stub_attribute;
- loc = loc;
- body = Lprim(prim, List.map (fun id -> Lvar id) params, loc) }
-
-let transl_primitive_application loc prim env ty path args =
- let prim_name = prim.prim_name in
- try
- let has_constant_constructor = match args with
- [_; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}]
- | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; _]
- | [_; {exp_desc = Texp_variant(_, None)}]
- | [{exp_desc = Texp_variant(_, None)}; _] -> true
- | _ -> false
- in
- specialize_primitive prim env ty ~has_constant_constructor
- with Not_found ->
- if String.length prim_name > 0 && prim_name.[0] = '%' then
- raise(Error(loc, Unknown_builtin_primitive prim_name));
- add_used_primitive loc env path;
- Pccall prim
-
(* To propagate structured constants *)
exception Not_constant
(* Insertion of debugging events *)
-let event_before exp lam = match lam with
-| Lstaticraise (_,_) -> lam
-| _ ->
- if !Clflags.debug && not !Clflags.native_code
- then Levent(lam, {lev_loc = exp.exp_loc;
- lev_kind = Lev_before;
- lev_repr = None;
- lev_env = Env.summary exp.exp_env})
- else lam
+let event_before = Translprim.event_before
-let event_after exp lam =
- if !Clflags.debug && not !Clflags.native_code
- then Levent(lam, {lev_loc = exp.exp_loc;
- lev_kind = Lev_after exp.exp_type;
- lev_repr = None;
- lev_env = Env.summary exp.exp_env})
- else lam
+let event_after = Translprim.event_after
let event_function exp lam =
if !Clflags.debug && not !Clflags.native_code then
else
lam None
-let primitive_is_ccall = function
- (* Determine if a primitive is a Pccall or will be turned later into
- a C function call that may raise an exception *)
- | Pccall _ | Pstringrefs | Pbytesrefs | Pbytessets | Parrayrefs _ |
- Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply |
- Prevapply -> true
- | _ -> false
-
(* Assertions *)
let assert_failed exp =
(* Translation of expressions *)
-let try_ids = Hashtbl.create 8
-
let rec transl_exp e =
List.iter (Translattribute.check_attribute e) e.exp_attributes;
let eval_once =
and transl_exp0 e =
match e.exp_desc with
- Texp_ident(path, _, {val_kind = Val_prim p}) ->
- let public_send = p.prim_name = "%send" in
- if public_send || p.prim_name = "%sendself" then
- let kind = if public_send then Public else Self in
- let obj = Ident.create "obj" and meth = Ident.create "meth" in
- Lfunction{kind = Curried; params = [obj; meth];
- attr = default_stub_attribute;
- loc = e.exp_loc;
- body = Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc)}
- else if p.prim_name = "%sendcache" then
- let obj = Ident.create "obj" and meth = Ident.create "meth" in
- let cache = Ident.create "cache" and pos = Ident.create "pos" in
- Lfunction{kind = Curried; params = [obj; meth; cache; pos];
- attr = default_stub_attribute;
- loc = e.exp_loc;
- body = Lsend(Cached, Lvar meth, Lvar obj,
- [Lvar cache; Lvar pos], e.exp_loc)}
- else
- transl_primitive e.exp_loc p e.exp_env e.exp_type (Some path)
+ | Texp_ident(path, _, {val_kind = Val_prim p}) ->
+ Translprim.transl_primitive e.exp_loc p e.exp_env e.exp_type (Some path)
| Texp_ident(_, _, {val_kind = Val_anc _}) ->
raise(Error(e.exp_loc, Free_super_var))
| Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) ->
exp_type = prim_type } as funct, oargs)
when List.length oargs >= p.prim_arity
&& List.for_all (fun (_, arg) -> arg <> None) oargs ->
- let args, args' = cut p.prim_arity oargs in
- let wrap f =
- if args' = []
- then event_after e f
- else
- let should_be_tailcall, funct =
- Translattribute.get_tailcall_attribute funct
- in
- let inlined, funct =
- Translattribute.get_and_remove_inlined_attribute funct
- in
- let specialised, funct =
- Translattribute.get_and_remove_specialised_attribute funct
- in
- let e = { e with exp_desc = Texp_apply(funct, oargs) } in
- event_after e
- (transl_apply ~should_be_tailcall ~inlined ~specialised
- f args' e.exp_loc)
+ let argl, extra_args = cut p.prim_arity oargs in
+ let arg_exps =
+ List.map (function _, Some x -> x | _ -> assert false) argl
in
- let wrap0 f =
- if args' = [] then f else wrap f in
- let args =
- List.map (function _, Some x -> x | _ -> assert false) args in
- let argl = transl_list args in
- let public_send = p.prim_name = "%send"
- || not !Clflags.native_code && p.prim_name = "%sendcache"in
- if public_send || p.prim_name = "%sendself" then
- let kind = if public_send then Public else Self in
- let obj = List.hd argl in
- wrap (Lsend (kind, List.nth argl 1, obj, [], e.exp_loc))
- else if p.prim_name = "%sendcache" then
- match argl with [obj; meth; cache; pos] ->
- wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
- | _ -> assert false
- else if p.prim_name = "%raise_with_backtrace" then begin
- let texn1 = List.hd args (* Should not fail by typing *) in
- let texn2,bt = match argl with
- | [a;b] -> a,b
- | _ -> assert false (* idem *)
- in
- let vexn = Ident.create "exn" in
- Llet(Strict, Pgenval, vexn, texn2,
- event_before e begin
- Lsequence(
- wrap (Lprim (Pccall prim_restore_raw_backtrace,
- [Lvar vexn;bt],
- e.exp_loc)),
- wrap0 (Lprim(Praise Raise_reraise,
- [event_after texn1 (Lvar vexn)],
- e.exp_loc))
- )
- end
- )
- end
+ let args = transl_list arg_exps in
+ let prim_exp = if extra_args = [] then Some e else None in
+ let lam =
+ Translprim.transl_primitive_application
+ e.exp_loc p e.exp_env prim_type path
+ prim_exp args arg_exps
+ in
+ if extra_args = [] then lam
else begin
- let prim = transl_primitive_application
- e.exp_loc p e.exp_env prim_type (Some path) args in
- match (prim, args) with
- (Praise k, [arg1]) ->
- let targ = List.hd argl in
- let k =
- match k, targ with
- | Raise_regular, Lvar id
- when Hashtbl.mem try_ids id ->
- Raise_reraise
- | _ ->
- k
- in
- wrap0 (Lprim(Praise k, [event_after arg1 targ], e.exp_loc))
- | (Ploc kind, []) ->
- lam_of_loc kind e.exp_loc
- | (Ploc kind, [arg1]) ->
- let lam = lam_of_loc kind arg1.exp_loc in
- Lprim(Pmakeblock(0, Immutable, None), lam :: argl, e.exp_loc)
- | (Ploc _, _) -> assert false
- | (_, _) ->
- begin match (prim, argl) with
- | (Plazyforce, [a]) ->
- wrap (Matching.inline_lazy_force a e.exp_loc)
- | (Plazyforce, _) -> assert false
- |_ -> let p = Lprim(prim, argl, e.exp_loc) in
- if primitive_is_ccall prim then wrap p else wrap0 p
- end
+ let should_be_tailcall, funct =
+ Translattribute.get_tailcall_attribute funct
+ in
+ let inlined, funct =
+ Translattribute.get_and_remove_inlined_attribute funct
+ in
+ let specialised, funct =
+ Translattribute.get_and_remove_specialised_attribute funct
+ in
+ let e = { e with exp_desc = Texp_apply(funct, oargs) } in
+ event_after e
+ (transl_apply ~should_be_tailcall ~inlined ~specialised
+ lam extra_args e.exp_loc)
end
| Texp_apply(funct, oargs) ->
let should_be_tailcall, funct =
do *)
begin match Typeopt.classify_lazy_argument e with
| `Constant_or_function ->
- (* a constant expr of type <> float gets compiled as itself *)
+ (* A constant expr (of type <> float if [Config.flat_float_array] is
+ true) gets compiled as itself. *)
transl_exp e
- | `Float ->
+ | `Float_that_cannot_be_shortcut ->
(* We don't need to wrap with Popaque: this forward
- block will never be shortcutted since it points to a float. *)
+ block will never be shortcutted since it points to a float
+ and Config.flat_float_array is true. *)
Lprim(Pmakeblock(Obj.forward_tag, Immutable, None),
[transl_exp e], e.exp_loc)
| `Identifier `Forward_value ->
List.map transl_case cases
and transl_case_try {c_lhs; c_guard; c_rhs} =
- match c_lhs.pat_desc with
- | Tpat_var (id, _)
- | Tpat_alias (_, id, _) ->
- Hashtbl.replace try_ids id ();
- Misc.try_finally
- (fun () -> c_lhs, transl_guard c_guard c_rhs)
- (fun () -> Hashtbl.remove try_ids id)
- | _ ->
- c_lhs, transl_guard c_guard c_rhs
+ let rec iter_exn_names f pat =
+ match pat.pat_desc with
+ | Tpat_var (id, _) -> f id
+ | Tpat_alias (p, id, _) ->
+ f id;
+ iter_exn_names f p
+ | _ -> ()
+ in
+ iter_exn_names Translprim.add_exception_ident c_lhs;
+ Misc.try_finally
+ (fun () -> c_lhs, transl_guard c_guard c_rhs)
+ (fun () ->
+ iter_exn_names Translprim.remove_exception_ident c_lhs)
and transl_cases_try cases =
let cases =
Matching.for_function loc repr (Lvar param)
(transl_cases cases) partial)
-and transl_let rec_flag pat_expr_list body =
+(*
+ Notice: transl_let consumes (ie compiles) its pat_expr_list argument,
+ and returns a function that will take the body of the lambda-let construct.
+ This complication allows choosing any compilation order for the
+ bindings and body of let constructs.
+*)
+and transl_let rec_flag pat_expr_list =
match rec_flag with
Nonrecursive ->
let rec transl = function
[] ->
- body
+ fun body -> body
| {vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc} :: rem ->
let lam = transl_exp expr in
let lam =
let lam =
Translattribute.add_specialise_attribute lam vb_loc attr
in
- Matching.for_let pat.pat_loc lam pat (transl rem)
+ let mk_body = transl rem in
+ fun body -> Matching.for_let pat.pat_loc lam pat (mk_body body)
in transl pat_expr_list
| Recursive ->
let idlist =
vb_attributes
in
(id, lam) in
- Lletrec(List.map2 transl_case pat_expr_list idlist, body)
+ let lam_bds = List.map2 transl_case pat_expr_list idlist in
+ fun body -> Lletrec(lam_bds, body)
and transl_setinstvar loc self var expr =
Lprim(Psetfield_computed (maybe_pointer expr, Assignment),
and cases = transl_cases pat_expr_list
and exn_cases = transl_cases_try exn_pat_expr_list in
let static_catch body val_ids handler =
- let static_exception_id = next_negative_raise_count () in
+ let static_exception_id = next_raise_count () in
Lstaticcatch
(Ltrywith (Lstaticraise (static_exception_id, body), id,
Matching.for_trywith (Lvar id) exn_cases),
| Free_super_var ->
fprintf ppf
"Ancestor names can only be used to select inherited methods"
- | Unknown_builtin_primitive prim_name ->
- fprintf ppf "Unknown builtin primitive \"%s\"" prim_name
| Unreachable_reached ->
fprintf ppf "Unreachable expression was reached"
-> lambda -> (arg_label * expression option) list
-> Location.t -> lambda
val transl_let: rec_flag -> value_binding list -> lambda -> lambda
-val transl_primitive: Location.t -> Primitive.description -> Env.t
- -> Types.type_expr -> Path.t option -> lambda
val transl_extension_constructor: Env.t -> Path.t option ->
extension_constructor -> lambda
-val used_primitives: (Path.t, Location.t) Hashtbl.t
-
type error =
Free_super_var
- | Unknown_builtin_primitive of string
| Unreachable_reached
exception Error of Location.t * error
open Translclass
type error =
- Circular_dependency of Ident.t
+ Circular_dependency of Ident.t list
| Conflicting_inline_attributes
exception Error of Location.t * error
let carg = apply_coercion loc Alias cc_arg (Lvar param) in
apply_coercion_result loc strict arg [param] [carg] cc_res
| Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
- transl_primitive pc_loc pc_desc pc_env pc_type None
+ Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None
| Tcoerce_alias (path, cc) ->
name_lambda strict arg
(fun _ -> apply_coercion loc Alias cc (transl_normal_path path))
and wrap_id_pos_list loc id_pos_list get_field lam =
let fv = free_variables lam in
(*Format.eprintf "%a@." Printlambda.lambda lam;
- IdentSet.iter (fun id -> Format.eprintf "%a " Ident.print id) fv;
+ Ident.Set.iter (fun id -> Format.eprintf "%a " Ident.print id) fv;
Format.eprintf "@.";*)
let (lam,s) =
List.fold_left (fun (lam,s) (id',pos,c) ->
- if IdentSet.mem id' fv then
+ if Ident.Set.mem id' fv then
let id'' = Ident.create (Ident.name id') in
(Llet(Alias, Pgenval, id'',
apply_coercion loc Alias c (get_field pos),lam),
- Ident.add id' (Lvar id'') s)
+ Ident.Map.add id' (Lvar id'') s)
else (lam,s))
- (lam, Ident.empty) id_pos_list
+ (lam, Ident.Map.empty) id_pos_list
in
- if s == Ident.empty then lam else subst_lambda s lam
+ if s == Ident.Map.empty then lam else Lambda.subst s lam
(* Compose two coercions
let init_shape modl =
let rec init_shape_mod env mty =
match Mtype.scrape env mty with
- Mty_ident _ ->
+ Mty_ident _
+ | Mty_alias (Mta_present, _) ->
raise Not_found
- | Mty_alias _ ->
+ | Mty_alias (Mta_absent, _) ->
Const_block (1, [Const_pointer 0])
| Mty_signature sg ->
Const_block(0, [Const_block(0, init_shape_struct env sg)])
(* Reorder bindings to honor dependencies. *)
-type binding_status = Undefined | Inprogress | Defined
+type binding_status =
+ | Undefined
+ | Inprogress of int option (** parent node *)
+ | Defined
+
+let extract_unsafe_cycle id status cycle_start =
+ let rec collect stop l i = match status.(i) with
+ | Inprogress None | Undefined | Defined -> assert false
+ | Inprogress Some i when i = stop -> id.(i) :: l
+ | Inprogress Some i -> collect stop (id.(i)::l) i in
+ collect cycle_start [id.(cycle_start)] cycle_start
+(* This yields [cycle_start; ...; cycle_start]. The start of the cycle
+ is duplicated to make the cycle more visible in the corresponding error
+ message. *)
let reorder_rec_bindings bindings =
let id = Array.of_list (List.map (fun (id,_,_,_) -> id) bindings)
let num_bindings = Array.length id in
let status = Array.make num_bindings Undefined in
let res = ref [] in
- let rec emit_binding i =
+ let rec emit_binding parent i =
match status.(i) with
Defined -> ()
- | Inprogress -> raise(Error(loc.(i), Circular_dependency id.(i)))
+ | Inprogress _ ->
+ status.(i) <- Inprogress parent;
+ let cycle = extract_unsafe_cycle id status i in
+ raise(Error(loc.(i), Circular_dependency cycle))
| Undefined ->
if init.(i) = None then begin
- status.(i) <- Inprogress;
+ status.(i) <- Inprogress parent;
for j = 0 to num_bindings - 1 do
- if IdentSet.mem id.(j) fv.(i) then emit_binding j
+ if Ident.Set.mem id.(j) fv.(i) then emit_binding (Some i) j
done
end;
res := (id.(i), init.(i), rhs.(i)) :: !res;
status.(i) <- Defined in
for i = 0 to num_bindings - 1 do
match status.(i) with
- Undefined -> emit_binding i
- | Inprogress -> assert false
+ Undefined -> emit_binding None i
+ | Inprogress _ -> assert false
| Defined -> ()
done;
List.rev !res
and transl_struct loc fields cc rootpath str =
transl_structure loc fields cc rootpath str.str_final_env str.str_items
+(* The function transl_structure is called by the bytecode compiler.
+ Some effort is made to compile in top to bottom order, in order to display
+ warning by increasing locations. *)
and transl_structure loc fields cc rootpath final_env = function
[] ->
let body, size =
Format.eprintf "@]@.";*)
let v = Array.of_list (List.rev fields) in
let get_field pos = Lvar v.(pos)
- and ids = List.fold_right IdentSet.add fields IdentSet.empty in
+ and ids = List.fold_right Ident.Set.add fields Ident.Set.empty in
let lam =
Lprim(Pmakeblock(0, Immutable, None),
List.map
(fun (pos, cc) ->
match cc with
Tcoerce_primitive p ->
- transl_primitive p.pc_loc
+ Translprim.transl_primitive p.pc_loc
p.pc_desc p.pc_env p.pc_type None
| _ -> apply_coercion loc Strict cc (get_field pos))
pos_cc_list, loc)
and id_pos_list =
- List.filter (fun (id,_,_) -> not (IdentSet.mem id ids))
+ List.filter (fun (id,_,_) -> not (Ident.Set.mem id ids))
id_pos_list
in
wrap_id_pos_list loc id_pos_list get_field lam,
in
Lsequence(transl_exp expr, body), size
| Tstr_value(rec_flag, pat_expr_list) ->
+ (* Translate bindings first *)
+ let mk_lam_let = transl_let rec_flag pat_expr_list in
let ext_fields = rev_let_bound_idents pat_expr_list @ fields in
+ (* Then, translate remainder of struct *)
let body, size =
transl_structure loc ext_fields cc rootpath final_env rem
in
- transl_let rec_flag pat_expr_list body, size
+ mk_lam_let body, size
| Tstr_primitive descr ->
record_primitive descr.val_val;
transl_structure loc fields cc rootpath final_env rem
size
| Tstr_module mb ->
let id = mb.mb_id in
- let body, size =
- transl_structure loc (id :: fields) cc rootpath final_env rem
- in
+ (* Translate module first *)
let module_body =
transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr
in
Translattribute.add_inline_attribute module_body mb.mb_loc
mb.mb_attributes
in
+ (* Translate remainder second *)
+ let body, size =
+ transl_structure loc (id :: fields) cc rootpath final_env rem
+ in
let module_body =
Levent (module_body, {
lev_loc = mb.mb_loc;
let scan_used_globals lam =
let globals = ref Ident.Set.empty in
let rec scan lam =
- Lambda.iter scan lam;
+ Lambda.iter_head_constructor scan lam;
match lam with
Lprim ((Pgetglobal id | Psetglobal id), _, _) ->
globals := Ident.Set.add id !globals
Ident.Set.add id req
in
let required =
- Hashtbl.fold
- (fun path _ -> add_global (Path.head path)) used_primitives
+ List.fold_left
+ (fun acc path -> add_global (Path.head path) acc)
(if flambda then globals else Ident.Set.empty)
+ (Translprim.get_used_primitives ())
in
let required =
List.fold_right add_global (Env.get_required_globals ()) required
in
Env.reset_required_globals ();
- Hashtbl.clear used_primitives;
+ Translprim.clear_used_primitives ();
required
(* Compile an implementation *)
let transl_implementation_flambda module_name (str, cc) =
reset_labels ();
primitive_declarations := [];
- Hashtbl.clear used_primitives;
+ Translprim.clear_used_primitives ();
let module_id = Ident.create_persistent module_name in
let body, size =
Translobj.transl_label_init
"map" is a table from defined idents to (pos in global block, coercion).
"prim" is a list of (pos in global block, primitive declaration). *)
-let transl_store_subst = ref Ident.empty
+let transl_store_subst = ref Ident.Map.empty
(** In the native toplevel, this reference is threaded through successive
calls of transl_store_structure *)
let nat_toplevel_name id =
- try match Ident.find_same id !transl_store_subst with
+ try match Ident.Map.find id !transl_store_subst with
| Lprim(Pfield pos, [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos)
| _ -> raise Not_found
with Not_found ->
fun (pos, cc) ->
match cc with
| Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
- transl_primitive pc_loc pc_desc pc_env pc_type None
+ Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None
| _ -> apply_coercion loc Strict cc (Lvar ids.(pos))
| item :: rem ->
match item.str_desc with
| Tstr_eval (expr, _attrs) ->
- Lsequence(subst_lambda subst (transl_exp expr),
+ Lsequence(Lambda.subst subst (transl_exp expr),
transl_store rootpath subst rem)
| Tstr_value(rec_flag, pat_expr_list) ->
let ids = let_bound_idents pat_expr_list in
let lam =
transl_let rec_flag pat_expr_list (store_idents Location.none ids)
in
- Lsequence(subst_lambda subst lam,
+ Lsequence(Lambda.subst subst lam,
transl_store rootpath (add_idents false ids subst) rem)
| Tstr_primitive descr ->
record_primitive descr.val_val;
transl_type_extension item.str_env rootpath tyext
(store_idents Location.none ids)
in
- Lsequence(subst_lambda subst lam,
+ Lsequence(Lambda.subst subst lam,
transl_store rootpath (add_idents false ids subst) rem)
| Tstr_exception ext ->
let id = ext.ext_id in
let path = field_path rootpath id in
let lam = transl_extension_constructor item.str_env path ext in
- Lsequence(Llet(Strict, Pgenval, id, subst_lambda subst lam,
+ Lsequence(Llet(Strict, Pgenval, id, Lambda.subst subst lam,
store_ident ext.ext_loc id),
transl_store rootpath (add_ident false id subst) rem)
| Tstr_module{mb_id=id;mb_loc=loc;
let subst = !transl_store_subst in
Lsequence(lam,
Llet(Strict, Pgenval, id,
- subst_lambda subst
+ Lambda.subst subst
(Lprim(Pmakeblock(0, Immutable, None),
List.map (fun id -> Lvar id)
(defined_idents str.str_items), loc)),
let field = field_of_str loc str in
Lsequence(lam,
Llet(Strict, Pgenval, id,
- subst_lambda subst
+ Lambda.subst subst
(Lprim(Pmakeblock(0, Immutable, None),
List.map field map, loc)),
Lsequence(store_ident loc id,
the compilation unit (add_ident true returns subst unchanged).
If not, we can use the value from the global
(add_ident true adds id -> Pgetglobal... to subst). *)
- Llet(Strict, Pgenval, id, subst_lambda subst lam,
+ Llet(Strict, Pgenval, id, Lambda.subst subst lam,
Lsequence(store_ident loc id,
transl_store rootpath (add_ident true id subst) rem))
| Tstr_recmodule bindings ->
let ids = List.map (fun mb -> mb.mb_id) bindings in
compile_recmodule
(fun id modl _loc ->
- subst_lambda subst
+ Lambda.subst subst
(transl_module Tcoerce_none
(field_path rootpath id) modl))
bindings
let lam =
Lletrec(class_bindings, store_idents Location.none ids)
in
- Lsequence(subst_lambda subst lam,
+ Lsequence(Lambda.subst subst lam,
transl_store rootpath (add_idents false ids subst) rem)
| Tstr_include{
| [], [] ->
transl_store rootpath (add_idents true ids0 subst) rem
| id :: ids, arg :: args ->
- Llet(Alias, Pgenval, id, subst_lambda subst (field arg),
+ Llet(Alias, Pgenval, id, Lambda.subst subst (field arg),
Lsequence(store_ident loc id,
loop ids args))
| _ -> assert false
store_idents (pos + 1) idl))
in
Llet(Strict, Pgenval, mid,
- subst_lambda subst (transl_module Tcoerce_none None modl),
+ Lambda.subst subst (transl_module Tcoerce_none None modl),
store_idents 0 ids)
| Tstr_modtype _
| Tstr_open _
let (pos, cc) = Ident.find_same id map in
match cc with
Tcoerce_none ->
- Ident.add id
+ Ident.Map.add id
(Lprim(Pfield pos,
[Lprim(Pgetglobal glob, [], Location.none)],
Location.none))
and store_primitive (pos, prim) cont =
Lsequence(Lprim(Psetfield(pos, Pointer, Root_initialization),
[Lprim(Pgetglobal glob, [], Location.none);
- transl_primitive Location.none
+ Translprim.transl_primitive Location.none
prim.pc_desc prim.pc_env prim.pc_type None],
Location.none),
cont)
let transl_store_gen module_name ({ str_items = str }, restr) topl =
reset_labels ();
primitive_declarations := [];
- Hashtbl.clear used_primitives;
+ Translprim.clear_used_primitives ();
let module_id = Ident.create_persistent module_name in
let (map, prims, size) =
build_ident_map restr (defined_idents str) (more_idents str) in
let f = function
| [ { str_desc = Tstr_eval (expr, _attrs) } ] when topl ->
assert (size = 0);
- subst_lambda !transl_store_subst (transl_exp expr)
+ Lambda.subst !transl_store_subst (transl_exp expr)
| str -> transl_store_structure module_id map prims str in
transl_store_label_init module_id size f str
(*size, transl_label_init (transl_store_structure module_id map prims str)*)
let transl_store_implementation module_name (str, restr) =
let s = !transl_store_subst in
- transl_store_subst := Ident.empty;
+ transl_store_subst := Ident.Map.empty;
let (i, code) = transl_store_gen module_name (str, restr) false in
transl_store_subst := s;
{ Lambda.main_module_block_size = i;
let toploop_setvalue_id id = toploop_setvalue id (Lvar id)
let close_toplevel_term (lam, ()) =
- IdentSet.fold (fun id l -> Llet(Strict, Pgenval, id,
+ Ident.Set.fold (fun id l -> Llet(Strict, Pgenval, id,
toploop_getvalue id, l))
(free_variables lam) lam
let transl_toplevel_definition str =
reset_labels ();
- Hashtbl.clear used_primitives;
+ Translprim.clear_used_primitives ();
make_sequence transl_toplevel_item_and_close str.str_items
(* Compile the initialization code for a packed library *)
open Format
+let print_cycle ppf =
+ Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf "@ -> ")
+ Printtyp.ident ppf
+
let report_error ppf = function
- Circular_dependency id ->
+ Circular_dependency cycle ->
+ let[@manual.ref "s-recursive-modules"] chapter, section = 8, 4 in
fprintf ppf
- "@[Cannot safely evaluate the definition@ \
- of the recursively-defined module %a@]"
- Printtyp.ident id
+ "@[Cannot safely evaluate the definition of the following cycle@ \
+ of recursively-defined modules:@ %a.@ \
+ There are no safe modules in this cycle@ (see manual section %d.%d)@]"
+ print_cycle cycle chapter section
| Conflicting_inline_attributes ->
fprintf ppf
"@[Conflicting ``inline'' attributes@]"
let reset () =
primitive_declarations := [];
- transl_store_subst := Ident.empty;
- toploop_ident.Ident.flags <- 0;
+ transl_store_subst := Ident.Map.empty;
aliased_idents := Ident.empty;
Env.reset_required_globals ();
- Hashtbl.clear used_primitives
+ Translprim.clear_used_primitives ()
val primitive_declarations: Primitive.description list ref
type error =
- Circular_dependency of Ident.t
+ Circular_dependency of Ident.t list
| Conflicting_inline_attributes
exception Error of Location.t * error
let wrapping = ref false
let top_env = ref Env.empty
let classes = ref []
-let method_ids = ref IdentSet.empty
+let method_ids = ref Ident.Set.empty
let oo_add_class id =
classes := id :: !classes;
cache_required := req;
top_env := env;
classes := [];
- method_ids := IdentSet.empty;
+ method_ids := Ident.Set.empty;
let lambda = f x in
let lambda =
List.fold_left
wrapping := false;
top_env := Env.empty;
classes := [];
- method_ids := IdentSet.empty
+ method_ids := Ident.Set.empty
val transl_store_label_init:
Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda
-val method_ids: IdentSet.t ref (* reset when starting a new wrapper *)
+val method_ids: Ident.Set.t ref (* reset when starting a new wrapper *)
val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
val oo_add_class: Ident.t -> Env.t * bool
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Translation of primitives *)
+
+open Misc
+open Asttypes
+open Primitive
+open Types
+open Typedtree
+open Typeopt
+open Lambda
+
+type error =
+ | Unknown_builtin_primitive of string
+ | Wrong_arity_builtin_primitive of string
+
+exception Error of Location.t * error
+
+(* Insertion of debugging events *)
+
+let event_before exp lam = match lam with
+| Lstaticraise (_,_) -> lam
+| _ ->
+ if !Clflags.debug && not !Clflags.native_code
+ then Levent(lam, {lev_loc = exp.exp_loc;
+ lev_kind = Lev_before;
+ lev_repr = None;
+ lev_env = Env.summary exp.exp_env})
+ else lam
+
+let event_after exp lam =
+ if !Clflags.debug && not !Clflags.native_code
+ then Levent(lam, {lev_loc = exp.exp_loc;
+ lev_kind = Lev_after exp.exp_type;
+ lev_repr = None;
+ lev_env = Env.summary exp.exp_env})
+ else lam
+
+type comparison =
+ | Equal
+ | Not_equal
+ | Less_equal
+ | Less_than
+ | Greater_equal
+ | Greater_than
+ | Compare
+
+type comparison_kind =
+ | Compare_generic
+ | Compare_ints
+ | Compare_floats
+ | Compare_strings
+ | Compare_bytes
+ | Compare_nativeints
+ | Compare_int32s
+ | Compare_int64s
+
+type loc_kind =
+ | Loc_FILE
+ | Loc_LINE
+ | Loc_MODULE
+ | Loc_LOC
+ | Loc_POS
+
+type prim =
+ | Primitive of Lambda.primitive
+ | Comparison of comparison * comparison_kind
+ | Raise of Lambda.raise_kind
+ | Raise_with_backtrace
+ | Lazy_force
+ | Loc of loc_kind
+ | Send
+ | Send_self
+ | Send_cache
+
+let used_primitives = Hashtbl.create 7
+let add_used_primitive loc env path =
+ match path with
+ Some (Path.Pdot _ as path) ->
+ let path = Env.normalize_path (Some loc) env path in
+ let unit = Path.head path in
+ if Ident.global unit && not (Hashtbl.mem used_primitives path)
+ then Hashtbl.add used_primitives path loc
+ | _ -> ()
+
+let clear_used_primitives () = Hashtbl.clear used_primitives
+let get_used_primitives () =
+ Hashtbl.fold (fun path _ acc -> path :: acc) used_primitives []
+
+let gen_array_kind =
+ if Config.flat_float_array then Pgenarray else Paddrarray
+
+let primitives_table = create_hashtable 57 [
+ "%identity", Primitive Pidentity;
+ "%bytes_to_string", Primitive Pbytes_to_string;
+ "%bytes_of_string", Primitive Pbytes_of_string;
+ "%ignore", Primitive Pignore;
+ "%revapply", Primitive Prevapply;
+ "%apply", Primitive Pdirapply;
+ "%loc_LOC", Loc Loc_LOC;
+ "%loc_FILE", Loc Loc_FILE;
+ "%loc_LINE", Loc Loc_LINE;
+ "%loc_POS", Loc Loc_POS;
+ "%loc_MODULE", Loc Loc_MODULE;
+ "%field0", Primitive (Pfield 0);
+ "%field1", Primitive (Pfield 1);
+ "%setfield0", Primitive (Psetfield(0, Pointer, Assignment));
+ "%makeblock", Primitive (Pmakeblock(0, Immutable, None));
+ "%makemutable", Primitive (Pmakeblock(0, Mutable, None));
+ "%raise", Raise Raise_regular;
+ "%reraise", Raise Raise_reraise;
+ "%raise_notrace", Raise Raise_notrace;
+ "%raise_with_backtrace", Raise_with_backtrace;
+ "%sequand", Primitive Psequand;
+ "%sequor", Primitive Psequor;
+ "%boolnot", Primitive Pnot;
+ "%big_endian", Primitive (Pctconst Big_endian);
+ "%backend_type", Primitive (Pctconst Backend_type);
+ "%word_size", Primitive (Pctconst Word_size);
+ "%int_size", Primitive (Pctconst Int_size);
+ "%max_wosize", Primitive (Pctconst Max_wosize);
+ "%ostype_unix", Primitive (Pctconst Ostype_unix);
+ "%ostype_win32", Primitive (Pctconst Ostype_win32);
+ "%ostype_cygwin", Primitive (Pctconst Ostype_cygwin);
+ "%negint", Primitive Pnegint;
+ "%succint", Primitive (Poffsetint 1);
+ "%predint", Primitive (Poffsetint(-1));
+ "%addint", Primitive Paddint;
+ "%subint", Primitive Psubint;
+ "%mulint", Primitive Pmulint;
+ "%divint", Primitive (Pdivint Safe);
+ "%modint", Primitive (Pmodint Safe);
+ "%andint", Primitive Pandint;
+ "%orint", Primitive Porint;
+ "%xorint", Primitive Pxorint;
+ "%lslint", Primitive Plslint;
+ "%lsrint", Primitive Plsrint;
+ "%asrint", Primitive Pasrint;
+ "%eq", Primitive (Pintcomp Ceq);
+ "%noteq", Primitive (Pintcomp Cne);
+ "%ltint", Primitive (Pintcomp Clt);
+ "%leint", Primitive (Pintcomp Cle);
+ "%gtint", Primitive (Pintcomp Cgt);
+ "%geint", Primitive (Pintcomp Cge);
+ "%incr", Primitive (Poffsetref(1));
+ "%decr", Primitive (Poffsetref(-1));
+ "%intoffloat", Primitive Pintoffloat;
+ "%floatofint", Primitive Pfloatofint;
+ "%negfloat", Primitive Pnegfloat;
+ "%absfloat", Primitive Pabsfloat;
+ "%addfloat", Primitive Paddfloat;
+ "%subfloat", Primitive Psubfloat;
+ "%mulfloat", Primitive Pmulfloat;
+ "%divfloat", Primitive Pdivfloat;
+ "%eqfloat", Primitive (Pfloatcomp CFeq);
+ "%noteqfloat", Primitive (Pfloatcomp CFneq);
+ "%ltfloat", Primitive (Pfloatcomp CFlt);
+ "%lefloat", Primitive (Pfloatcomp CFle);
+ "%gtfloat", Primitive (Pfloatcomp CFgt);
+ "%gefloat", Primitive (Pfloatcomp CFge);
+ "%string_length", Primitive Pstringlength;
+ "%string_safe_get", Primitive Pstringrefs;
+ "%string_safe_set", Primitive Pbytessets;
+ "%string_unsafe_get", Primitive Pstringrefu;
+ "%string_unsafe_set", Primitive Pbytessetu;
+ "%bytes_length", Primitive Pbyteslength;
+ "%bytes_safe_get", Primitive Pbytesrefs;
+ "%bytes_safe_set", Primitive Pbytessets;
+ "%bytes_unsafe_get", Primitive Pbytesrefu;
+ "%bytes_unsafe_set", Primitive Pbytessetu;
+ "%array_length", Primitive (Parraylength gen_array_kind);
+ "%array_safe_get", Primitive (Parrayrefs gen_array_kind);
+ "%array_safe_set", Primitive (Parraysets gen_array_kind);
+ "%array_unsafe_get", Primitive (Parrayrefu gen_array_kind);
+ "%array_unsafe_set", Primitive (Parraysetu gen_array_kind);
+ "%obj_size", Primitive (Parraylength gen_array_kind);
+ "%obj_field", Primitive (Parrayrefu gen_array_kind);
+ "%obj_set_field", Primitive (Parraysetu gen_array_kind);
+ "%floatarray_length", Primitive (Parraylength Pfloatarray);
+ "%floatarray_safe_get", Primitive (Parrayrefs Pfloatarray);
+ "%floatarray_safe_set", Primitive (Parraysets Pfloatarray);
+ "%floatarray_unsafe_get", Primitive (Parrayrefu Pfloatarray);
+ "%floatarray_unsafe_set", Primitive (Parraysetu Pfloatarray);
+ "%obj_is_int", Primitive Pisint;
+ "%lazy_force", Lazy_force;
+ "%nativeint_of_int", Primitive (Pbintofint Pnativeint);
+ "%nativeint_to_int", Primitive (Pintofbint Pnativeint);
+ "%nativeint_neg", Primitive (Pnegbint Pnativeint);
+ "%nativeint_add", Primitive (Paddbint Pnativeint);
+ "%nativeint_sub", Primitive (Psubbint Pnativeint);
+ "%nativeint_mul", Primitive (Pmulbint Pnativeint);
+ "%nativeint_div", Primitive (Pdivbint { size = Pnativeint; is_safe = Safe });
+ "%nativeint_mod", Primitive (Pmodbint { size = Pnativeint; is_safe = Safe });
+ "%nativeint_and", Primitive (Pandbint Pnativeint);
+ "%nativeint_or", Primitive (Porbint Pnativeint);
+ "%nativeint_xor", Primitive (Pxorbint Pnativeint);
+ "%nativeint_lsl", Primitive (Plslbint Pnativeint);
+ "%nativeint_lsr", Primitive (Plsrbint Pnativeint);
+ "%nativeint_asr", Primitive (Pasrbint Pnativeint);
+ "%int32_of_int", Primitive (Pbintofint Pint32);
+ "%int32_to_int", Primitive (Pintofbint Pint32);
+ "%int32_neg", Primitive (Pnegbint Pint32);
+ "%int32_add", Primitive (Paddbint Pint32);
+ "%int32_sub", Primitive (Psubbint Pint32);
+ "%int32_mul", Primitive (Pmulbint Pint32);
+ "%int32_div", Primitive (Pdivbint { size = Pint32; is_safe = Safe });
+ "%int32_mod", Primitive (Pmodbint { size = Pint32; is_safe = Safe });
+ "%int32_and", Primitive (Pandbint Pint32);
+ "%int32_or", Primitive (Porbint Pint32);
+ "%int32_xor", Primitive (Pxorbint Pint32);
+ "%int32_lsl", Primitive (Plslbint Pint32);
+ "%int32_lsr", Primitive (Plsrbint Pint32);
+ "%int32_asr", Primitive (Pasrbint Pint32);
+ "%int64_of_int", Primitive (Pbintofint Pint64);
+ "%int64_to_int", Primitive (Pintofbint Pint64);
+ "%int64_neg", Primitive (Pnegbint Pint64);
+ "%int64_add", Primitive (Paddbint Pint64);
+ "%int64_sub", Primitive (Psubbint Pint64);
+ "%int64_mul", Primitive (Pmulbint Pint64);
+ "%int64_div", Primitive (Pdivbint { size = Pint64; is_safe = Safe });
+ "%int64_mod", Primitive (Pmodbint { size = Pint64; is_safe = Safe });
+ "%int64_and", Primitive (Pandbint Pint64);
+ "%int64_or", Primitive (Porbint Pint64);
+ "%int64_xor", Primitive (Pxorbint Pint64);
+ "%int64_lsl", Primitive (Plslbint Pint64);
+ "%int64_lsr", Primitive (Plsrbint Pint64);
+ "%int64_asr", Primitive (Pasrbint Pint64);
+ "%nativeint_of_int32", Primitive (Pcvtbint(Pint32, Pnativeint));
+ "%nativeint_to_int32", Primitive (Pcvtbint(Pnativeint, Pint32));
+ "%int64_of_int32", Primitive (Pcvtbint(Pint32, Pint64));
+ "%int64_to_int32", Primitive (Pcvtbint(Pint64, Pint32));
+ "%int64_of_nativeint", Primitive (Pcvtbint(Pnativeint, Pint64));
+ "%int64_to_nativeint", Primitive (Pcvtbint(Pint64, Pnativeint));
+ "%caml_ba_ref_1",
+ Primitive
+ (Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout));
+ "%caml_ba_ref_2",
+ Primitive
+ (Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout));
+ "%caml_ba_ref_3",
+ Primitive
+ (Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout));
+ "%caml_ba_set_1",
+ Primitive
+ (Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout));
+ "%caml_ba_set_2",
+ Primitive
+ (Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout));
+ "%caml_ba_set_3",
+ Primitive
+ (Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout));
+ "%caml_ba_unsafe_ref_1",
+ Primitive
+ (Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout));
+ "%caml_ba_unsafe_ref_2",
+ Primitive
+ (Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout));
+ "%caml_ba_unsafe_ref_3",
+ Primitive
+ (Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout));
+ "%caml_ba_unsafe_set_1",
+ Primitive
+ (Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout));
+ "%caml_ba_unsafe_set_2",
+ Primitive
+ (Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout));
+ "%caml_ba_unsafe_set_3",
+ Primitive
+ (Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout));
+ "%caml_ba_dim_1", Primitive (Pbigarraydim(1));
+ "%caml_ba_dim_2", Primitive (Pbigarraydim(2));
+ "%caml_ba_dim_3", Primitive (Pbigarraydim(3));
+ "%caml_string_get16", Primitive (Pstring_load_16(false));
+ "%caml_string_get16u", Primitive (Pstring_load_16(true));
+ "%caml_string_get32", Primitive (Pstring_load_32(false));
+ "%caml_string_get32u", Primitive (Pstring_load_32(true));
+ "%caml_string_get64", Primitive (Pstring_load_64(false));
+ "%caml_string_get64u", Primitive (Pstring_load_64(true));
+ "%caml_string_set16", Primitive (Pbytes_set_16(false));
+ "%caml_string_set16u", Primitive (Pbytes_set_16(true));
+ "%caml_string_set32", Primitive (Pbytes_set_32(false));
+ "%caml_string_set32u", Primitive (Pbytes_set_32(true));
+ "%caml_string_set64", Primitive (Pbytes_set_64(false));
+ "%caml_string_set64u", Primitive (Pbytes_set_64(true));
+ "%caml_bytes_get16", Primitive (Pbytes_load_16(false));
+ "%caml_bytes_get16u", Primitive (Pbytes_load_16(true));
+ "%caml_bytes_get32", Primitive (Pbytes_load_32(false));
+ "%caml_bytes_get32u", Primitive (Pbytes_load_32(true));
+ "%caml_bytes_get64", Primitive (Pbytes_load_64(false));
+ "%caml_bytes_get64u", Primitive (Pbytes_load_64(true));
+ "%caml_bytes_set16", Primitive (Pbytes_set_16(false));
+ "%caml_bytes_set16u", Primitive (Pbytes_set_16(true));
+ "%caml_bytes_set32", Primitive (Pbytes_set_32(false));
+ "%caml_bytes_set32u", Primitive (Pbytes_set_32(true));
+ "%caml_bytes_set64", Primitive (Pbytes_set_64(false));
+ "%caml_bytes_set64u", Primitive (Pbytes_set_64(true));
+ "%caml_bigstring_get16", Primitive (Pbigstring_load_16(false));
+ "%caml_bigstring_get16u", Primitive (Pbigstring_load_16(true));
+ "%caml_bigstring_get32", Primitive (Pbigstring_load_32(false));
+ "%caml_bigstring_get32u", Primitive (Pbigstring_load_32(true));
+ "%caml_bigstring_get64", Primitive (Pbigstring_load_64(false));
+ "%caml_bigstring_get64u", Primitive (Pbigstring_load_64(true));
+ "%caml_bigstring_set16", Primitive (Pbigstring_set_16(false));
+ "%caml_bigstring_set16u", Primitive (Pbigstring_set_16(true));
+ "%caml_bigstring_set32", Primitive (Pbigstring_set_32(false));
+ "%caml_bigstring_set32u", Primitive (Pbigstring_set_32(true));
+ "%caml_bigstring_set64", Primitive (Pbigstring_set_64(false));
+ "%caml_bigstring_set64u", Primitive (Pbigstring_set_64(true));
+ "%bswap16", Primitive Pbswap16;
+ "%bswap_int32", Primitive (Pbbswap(Pint32));
+ "%bswap_int64", Primitive (Pbbswap(Pint64));
+ "%bswap_native", Primitive (Pbbswap(Pnativeint));
+ "%int_as_pointer", Primitive Pint_as_pointer;
+ "%opaque", Primitive Popaque;
+ "%send", Send;
+ "%sendself", Send_self;
+ "%sendcache", Send_cache;
+ "%equal", Comparison(Equal, Compare_generic);
+ "%notequal", Comparison(Not_equal, Compare_generic);
+ "%lessequal", Comparison(Less_equal, Compare_generic);
+ "%lessthan", Comparison(Less_than, Compare_generic);
+ "%greaterequal", Comparison(Greater_equal, Compare_generic);
+ "%greaterthan", Comparison(Greater_than, Compare_generic);
+ "%compare", Comparison(Compare, Compare_generic);
+]
+
+let lookup_primitive loc p env path =
+ match Hashtbl.find primitives_table p.prim_name with
+ | prim -> prim
+ | exception Not_found ->
+ if String.length p.prim_name > 0 && p.prim_name.[0] = '%' then
+ raise(Error(loc, Unknown_builtin_primitive p.prim_name));
+ add_used_primitive loc env path;
+ Primitive (Pccall p)
+
+let simplify_constant_constructor = function
+ | Equal -> true
+ | Not_equal -> true
+ | Less_equal -> false
+ | Less_than -> false
+ | Greater_equal -> false
+ | Greater_than -> false
+ | Compare -> false
+
+(* The following function computes the greatest lower bound in the
+ semilattice of array kinds:
+ gen
+ / \
+ addr float
+ |
+ int
+ Note that the GLB is not guaranteed to exist, in which case we return
+ our first argument instead of raising a fatal error because, although
+ it cannot happen in a well-typed program, (ab)use of Obj.magic can
+ probably trigger it.
+*)
+let glb_array_type t1 t2 =
+ match t1, t2 with
+ | Pfloatarray, (Paddrarray | Pintarray)
+ | (Paddrarray | Pintarray), Pfloatarray -> t1
+
+ | Pgenarray, x | x, Pgenarray -> x
+ | Paddrarray, x | x, Paddrarray -> x
+ | Pintarray, Pintarray -> Pintarray
+ | Pfloatarray, Pfloatarray -> Pfloatarray
+
+(* Specialize a primitive from available type information. *)
+
+let specialize_primitive env ty ~has_constant_constructor prim =
+ let param_tys =
+ match is_function_type env ty with
+ | None -> []
+ | Some (p1, rhs) ->
+ match is_function_type env rhs with
+ | None -> [p1]
+ | Some (p2, _) -> [p1;p2]
+ in
+ match prim, param_tys with
+ | Primitive (Psetfield(n, Pointer, init)), [_; p2] -> begin
+ match maybe_pointer_type env p2 with
+ | Pointer -> None
+ | Immediate -> Some (Primitive (Psetfield(n, Immediate, init)))
+ end
+ | Primitive (Parraylength t), [p] -> begin
+ let array_type = glb_array_type t (array_type_kind env p) in
+ if t = array_type then None
+ else Some (Primitive (Parraylength array_type))
+ end
+ | Primitive (Parrayrefu t), p1 :: _ -> begin
+ let array_type = glb_array_type t (array_type_kind env p1) in
+ if t = array_type then None
+ else Some (Primitive (Parrayrefu array_type))
+ end
+ | Primitive (Parraysetu t), p1 :: _ -> begin
+ let array_type = glb_array_type t (array_type_kind env p1) in
+ if t = array_type then None
+ else Some (Primitive (Parraysetu array_type))
+ end
+ | Primitive (Parrayrefs t), p1 :: _ -> begin
+ let array_type = glb_array_type t (array_type_kind env p1) in
+ if t = array_type then None
+ else Some (Primitive (Parrayrefs array_type))
+ end
+ | Primitive (Parraysets t), p1 :: _ -> begin
+ let array_type = glb_array_type t (array_type_kind env p1) in
+ if t = array_type then None
+ else Some (Primitive (Parraysets array_type))
+ end
+ | Primitive (Pbigarrayref(unsafe, n, Pbigarray_unknown,
+ Pbigarray_unknown_layout)), p1 :: _ -> begin
+ let (k, l) = bigarray_type_kind_and_layout env p1 in
+ match k, l with
+ | Pbigarray_unknown, Pbigarray_unknown_layout -> None
+ | _, _ -> Some (Primitive (Pbigarrayref(unsafe, n, k, l)))
+ end
+ | Primitive (Pbigarrayset(unsafe, n, Pbigarray_unknown,
+ Pbigarray_unknown_layout)), p1 :: _ -> begin
+ let (k, l) = bigarray_type_kind_and_layout env p1 in
+ match k, l with
+ | Pbigarray_unknown, Pbigarray_unknown_layout -> None
+ | _, _ -> Some (Primitive (Pbigarrayset(unsafe, n, k, l)))
+ end
+ | Primitive (Pmakeblock(tag, mut, None)), fields -> begin
+ let shape = List.map (Typeopt.value_kind env) fields in
+ let useful = List.exists (fun knd -> knd <> Pgenval) shape in
+ if useful then Some (Primitive (Pmakeblock(tag, mut, Some shape)))
+ else None
+ end
+ | Comparison(comp, Compare_generic), p1 :: _ ->
+ if (has_constant_constructor
+ && simplify_constant_constructor comp) then begin
+ Some (Comparison(comp, Compare_ints))
+ end else if (is_base_type env p1 Predef.path_int
+ || is_base_type env p1 Predef.path_char
+ || (maybe_pointer_type env p1 = Immediate)) then begin
+ Some (Comparison(comp, Compare_ints))
+ end else if is_base_type env p1 Predef.path_float then begin
+ Some (Comparison(comp, Compare_floats))
+ end else if is_base_type env p1 Predef.path_string then begin
+ Some (Comparison(comp, Compare_strings))
+ end else if is_base_type env p1 Predef.path_bytes then begin
+ Some (Comparison(comp, Compare_bytes))
+ end else if is_base_type env p1 Predef.path_nativeint then begin
+ Some (Comparison(comp, Compare_nativeints))
+ end else if is_base_type env p1 Predef.path_int32 then begin
+ Some (Comparison(comp, Compare_int32s))
+ end else if is_base_type env p1 Predef.path_int64 then begin
+ Some (Comparison(comp, Compare_int64s))
+ end else begin
+ None
+ end
+ | _ -> None
+
+let unboxed_compare name native_repr =
+ Primitive.make ~name ~alloc:false ~native_name:(name^"_unboxed")
+ ~native_repr_args:[native_repr;native_repr] ~native_repr_res:Untagged_int
+
+let caml_equal =
+ Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true
+let caml_string_equal =
+ Primitive.simple ~name:"caml_string_equal" ~arity:2 ~alloc:false
+let caml_bytes_equal =
+ Primitive.simple ~name:"caml_bytes_equal" ~arity:2 ~alloc:false
+let caml_notequal =
+ Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true
+let caml_string_notequal =
+ Primitive.simple ~name:"caml_string_notequal" ~arity:2 ~alloc:false
+let caml_bytes_notequal =
+ Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 ~alloc:false
+let caml_lessequal =
+ Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true
+let caml_string_lessequal =
+ Primitive.simple ~name:"caml_string_lessequal" ~arity:2 ~alloc:false
+let caml_bytes_lessequal =
+ Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 ~alloc:false
+let caml_lessthan =
+ Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true
+let caml_string_lessthan =
+ Primitive.simple ~name:"caml_string_lessthan" ~arity:2 ~alloc:false
+let caml_bytes_lessthan =
+ Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 ~alloc:false
+let caml_greaterequal =
+ Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true
+let caml_string_greaterequal =
+ Primitive.simple ~name:"caml_string_greaterequal" ~arity:2 ~alloc:false
+let caml_bytes_greaterequal =
+ Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 ~alloc:false
+let caml_greaterthan =
+ Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true
+let caml_string_greaterthan =
+ Primitive.simple ~name:"caml_string_greaterthan" ~arity:2 ~alloc: false
+let caml_bytes_greaterthan =
+ Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 ~alloc: false
+let caml_compare =
+ Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true
+let caml_int_compare =
+ (* Not unboxed since the comparison is done directly on tagged int *)
+ Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false
+let caml_float_compare =
+ unboxed_compare "caml_float_compare" Unboxed_float
+let caml_string_compare =
+ Primitive.simple ~name:"caml_string_compare" ~arity:2 ~alloc:false
+let caml_bytes_compare =
+ Primitive.simple ~name:"caml_bytes_compare" ~arity:2 ~alloc:false
+let caml_nativeint_compare =
+ unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint)
+let caml_int32_compare =
+ unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32)
+let caml_int64_compare =
+ unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64)
+
+let comparison_primitive comparison comparison_kind =
+ match comparison, comparison_kind with
+ | Equal, Compare_generic -> Pccall caml_equal
+ | Equal, Compare_ints -> Pintcomp Ceq
+ | Equal, Compare_floats -> Pfloatcomp CFeq
+ | Equal, Compare_strings -> Pccall caml_string_equal
+ | Equal, Compare_bytes -> Pccall caml_bytes_equal
+ | Equal, Compare_nativeints -> Pbintcomp(Pnativeint, Ceq)
+ | Equal, Compare_int32s -> Pbintcomp(Pint32, Ceq)
+ | Equal, Compare_int64s -> Pbintcomp(Pint64, Ceq)
+ | Not_equal, Compare_generic -> Pccall caml_notequal
+ | Not_equal, Compare_ints -> Pintcomp Cne
+ | Not_equal, Compare_floats -> Pfloatcomp CFneq
+ | Not_equal, Compare_strings -> Pccall caml_string_notequal
+ | Not_equal, Compare_bytes -> Pccall caml_bytes_notequal
+ | Not_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cne)
+ | Not_equal, Compare_int32s -> Pbintcomp(Pint32, Cne)
+ | Not_equal, Compare_int64s -> Pbintcomp(Pint64, Cne)
+ | Less_equal, Compare_generic -> Pccall caml_lessequal
+ | Less_equal, Compare_ints -> Pintcomp Cle
+ | Less_equal, Compare_floats -> Pfloatcomp CFle
+ | Less_equal, Compare_strings -> Pccall caml_string_lessequal
+ | Less_equal, Compare_bytes -> Pccall caml_bytes_lessequal
+ | Less_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cle)
+ | Less_equal, Compare_int32s -> Pbintcomp(Pint32, Cle)
+ | Less_equal, Compare_int64s -> Pbintcomp(Pint64, Cle)
+ | Less_than, Compare_generic -> Pccall caml_lessthan
+ | Less_than, Compare_ints -> Pintcomp Clt
+ | Less_than, Compare_floats -> Pfloatcomp CFlt
+ | Less_than, Compare_strings -> Pccall caml_string_lessthan
+ | Less_than, Compare_bytes -> Pccall caml_bytes_lessthan
+ | Less_than, Compare_nativeints -> Pbintcomp(Pnativeint, Clt)
+ | Less_than, Compare_int32s -> Pbintcomp(Pint32, Clt)
+ | Less_than, Compare_int64s -> Pbintcomp(Pint64, Clt)
+ | Greater_equal, Compare_generic -> Pccall caml_greaterequal
+ | Greater_equal, Compare_ints -> Pintcomp Cge
+ | Greater_equal, Compare_floats -> Pfloatcomp CFge
+ | Greater_equal, Compare_strings -> Pccall caml_string_greaterequal
+ | Greater_equal, Compare_bytes -> Pccall caml_bytes_greaterequal
+ | Greater_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cge)
+ | Greater_equal, Compare_int32s -> Pbintcomp(Pint32, Cge)
+ | Greater_equal, Compare_int64s -> Pbintcomp(Pint64, Cge)
+ | Greater_than, Compare_generic -> Pccall caml_greaterthan
+ | Greater_than, Compare_ints -> Pintcomp Cgt
+ | Greater_than, Compare_floats -> Pfloatcomp CFgt
+ | Greater_than, Compare_strings -> Pccall caml_string_greaterthan
+ | Greater_than, Compare_bytes -> Pccall caml_bytes_greaterthan
+ | Greater_than, Compare_nativeints -> Pbintcomp(Pnativeint, Cgt)
+ | Greater_than, Compare_int32s -> Pbintcomp(Pint32, Cgt)
+ | Greater_than, Compare_int64s -> Pbintcomp(Pint64, Cgt)
+ | Compare, Compare_generic -> Pccall caml_compare
+ | Compare, Compare_ints -> Pccall caml_int_compare
+ | Compare, Compare_floats -> Pccall caml_float_compare
+ | Compare, Compare_strings -> Pccall caml_string_compare
+ | Compare, Compare_bytes -> Pccall caml_bytes_compare
+ | Compare, Compare_nativeints -> Pccall caml_nativeint_compare
+ | Compare, Compare_int32s -> Pccall caml_int32_compare
+ | Compare, Compare_int64s -> Pccall caml_int64_compare
+
+let lambda_of_loc kind loc =
+ let loc_start = loc.Location.loc_start in
+ let (file, lnum, cnum) = Location.get_pos_info loc_start in
+ let enum = loc.Location.loc_end.Lexing.pos_cnum -
+ loc_start.Lexing.pos_cnum + cnum in
+ match kind with
+ | Loc_POS ->
+ Lconst (Const_block (0, [
+ Const_immstring file;
+ Const_base (Const_int lnum);
+ Const_base (Const_int cnum);
+ Const_base (Const_int enum);
+ ]))
+ | Loc_FILE -> Lconst (Const_immstring file)
+ | Loc_MODULE ->
+ let filename = Filename.basename file in
+ let name = Env.get_unit_name () in
+ let module_name = if name = "" then "//"^filename^"//" else name in
+ Lconst (Const_immstring module_name)
+ | Loc_LOC ->
+ let loc = Printf.sprintf "File %S, line %d, characters %d-%d"
+ file lnum cnum enum in
+ Lconst (Const_immstring loc)
+ | Loc_LINE -> Lconst (Const_base (Const_int lnum))
+
+let caml_restore_raw_backtrace =
+ Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false
+
+let try_ids = Hashtbl.create 8
+
+let add_exception_ident id =
+ Hashtbl.replace try_ids id ()
+
+let remove_exception_ident id =
+ Hashtbl.remove try_ids id
+
+let lambda_of_prim prim_name prim loc args arg_exps =
+ match prim, args with
+ | Primitive prim, args ->
+ Lprim(prim, args, loc)
+ | Comparison(comp, knd), args ->
+ let prim = comparison_primitive comp knd in
+ Lprim(prim, args, loc)
+ | Raise kind, [arg] ->
+ let kind =
+ match kind, arg with
+ | Raise_regular, Lvar argv when Hashtbl.mem try_ids argv ->
+ Raise_reraise
+ | _, _ ->
+ kind
+ in
+ let arg =
+ match arg_exps with
+ | None -> arg
+ | Some [arg_exp] -> event_after arg_exp arg
+ | Some _ -> assert false
+ in
+ Lprim(Praise kind, [arg], loc)
+ | Raise_with_backtrace, [exn; bt] ->
+ let vexn = Ident.create "exn" in
+ let raise_arg =
+ match arg_exps with
+ | None -> Lvar vexn
+ | Some [exn_exp; _] -> event_after exn_exp (Lvar vexn)
+ | Some _ -> assert false
+ in
+ Llet(Strict, Pgenval, vexn, exn,
+ Lsequence(Lprim(Pccall caml_restore_raw_backtrace,
+ [Lvar vexn; bt],
+ loc),
+ Lprim(Praise Raise_reraise, [raise_arg], loc)))
+ | Lazy_force, [arg] ->
+ Matching.inline_lazy_force arg Location.none
+ | Loc kind, [] ->
+ lambda_of_loc kind loc
+ | Loc kind, [arg] ->
+ let lam = lambda_of_loc kind loc in
+ Lprim(Pmakeblock(0, Immutable, None), [lam; arg], loc)
+ | Send, [obj; meth] ->
+ Lsend(Public, meth, obj, [], loc)
+ | Send_self, [obj; meth] ->
+ Lsend(Self, meth, obj, [], loc)
+ | Send_cache, [obj; meth; cache; pos] ->
+ Lsend(Cached, meth, obj, [cache; pos], loc)
+ | (Raise _ | Raise_with_backtrace
+ | Lazy_force | Loc _
+ | Send | Send_self | Send_cache), _ ->
+ raise(Error(loc, Wrong_arity_builtin_primitive prim_name))
+
+(* Eta-expand a primitive *)
+
+let transl_primitive loc p env ty path =
+ let prim = lookup_primitive loc p env path in
+ let has_constant_constructor = false in
+ let prim =
+ match specialize_primitive env ty ~has_constant_constructor prim with
+ | None -> prim
+ | Some prim -> prim
+ in
+ let rec make_params n =
+ if n <= 0 then [] else Ident.create "prim" :: make_params (n-1)
+ in
+ let params = make_params p.prim_arity in
+ let args = List.map (fun id -> Lvar id) params in
+ let body = lambda_of_prim p.prim_name prim loc args None in
+ match params with
+ | [] -> body
+ | _ ->
+ Lfunction{ kind = Curried; params;
+ attr = default_stub_attribute;
+ loc = loc;
+ body = body; }
+
+(* Determine if a primitive is a Pccall or will be turned later into
+ a C function call that may raise an exception *)
+let primitive_is_ccall = function
+ | Pccall _ | Pstringrefs | Pbytesrefs | Pbytessets | Parrayrefs _ |
+ Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply |
+ Prevapply -> true
+ | _ -> false
+
+(* Determine if a primitive should be surrounded by an "after" debug event *)
+let primitive_needs_event_after = function
+ | Primitive prim -> primitive_is_ccall prim
+ | Comparison(comp, knd) ->
+ primitive_is_ccall (comparison_primitive comp knd)
+ | Lazy_force | Send | Send_self | Send_cache -> true
+ | Raise _ | Raise_with_backtrace | Loc _ -> false
+
+let transl_primitive_application loc p env ty path exp args arg_exps =
+ let prim = lookup_primitive loc p env (Some path) in
+ let has_constant_constructor =
+ match arg_exps with
+ | [_; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}]
+ | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; _]
+ | [_; {exp_desc = Texp_variant(_, None)}]
+ | [{exp_desc = Texp_variant(_, None)}; _] -> true
+ | _ -> false
+ in
+ let prim =
+ match specialize_primitive env ty ~has_constant_constructor prim with
+ | None -> prim
+ | Some prim -> prim
+ in
+ let lam = lambda_of_prim p.prim_name prim loc args (Some arg_exps) in
+ let lam =
+ if primitive_needs_event_after prim then begin
+ match exp with
+ | None -> lam
+ | Some exp -> event_after exp lam
+ end else begin
+ lam
+ end
+ in
+ lam
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+ | Unknown_builtin_primitive prim_name ->
+ fprintf ppf "Unknown builtin primitive \"%s\"" prim_name
+ | Wrong_arity_builtin_primitive prim_name ->
+ fprintf ppf "Wrong arity for builtin primitive \"%s\"" prim_name
+
+let () =
+ Location.register_error_of_exn
+ (function
+ | Error (loc, err) ->
+ Some (Location.error_of_printer loc report_error err)
+ | _ ->
+ None
+ )
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Insertion of debugging events *)
+
+val event_before : Typedtree.expression -> Lambda.lambda -> Lambda.lambda
+
+val event_after : Typedtree.expression -> Lambda.lambda -> Lambda.lambda
+
+(* Translation of primitives *)
+
+val add_exception_ident : Ident.t -> unit
+val remove_exception_ident : Ident.t -> unit
+
+val clear_used_primitives : unit -> unit
+val get_used_primitives: unit -> Path.t list
+
+val transl_primitive :
+ Location.t -> Primitive.description -> Env.t ->
+ Types.type_expr -> Path.t option -> Lambda.lambda
+
+val transl_primitive_application :
+ Location.t -> Primitive.description -> Env.t ->
+ Types.type_expr -> Path.t -> Typedtree.expression option ->
+ Lambda.lambda list -> Typedtree.expression list -> Lambda.lambda
+
+(* Errors *)
+
+type error =
+ | Unknown_builtin_primitive of string
+ | Wrong_arity_builtin_primitive of string
+
+exception Error of Location.t * error
+
+open Format
+
+val report_error : formatter -> error -> unit
array.$(O): array.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h \
- caml/spacetime.h
+ caml/spacetime.h caml/io.h caml/stack.h
backtrace.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/backtrace.h \
bigarray.$(O): bigarray.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/bigarray.h caml/custom.h caml/fail.h \
caml/intext.h caml/io.h caml/hash.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
+ caml/signals.h
callback.$(O): callback.c caml/callback.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/fail.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
custom.$(O): custom.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/custom.h caml/fail.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h
+ caml/address_class.h caml/signals.h
debugger.$(O): debugger.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/debugger.h caml/osdeps.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
obj.$(O): obj.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
caml/mlvalues.h caml/fail.h caml/gc.h caml/interp.h caml/major_gc.h \
caml/freelist.h caml/memory.h caml/minor_gc.h caml/address_class.h \
- caml/prims.h caml/spacetime.h
+ caml/prims.h caml/spacetime.h caml/io.h caml/stack.h
parsing.$(O): parsing.c caml/config.h caml/m.h caml/s.h caml/mlvalues.h \
caml/misc.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
caml/minor_gc.h caml/address_class.h caml/alloc.h
caml/osdeps.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
caml/minor_gc.h caml/address_class.h caml/signals.h caml/stacks.h \
caml/sys.h caml/version.h caml/callback.h caml/startup_aux.h
-terminfo.$(O): terminfo.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
- caml/misc.h caml/mlvalues.h caml/fail.h caml/io.h
unix.$(O): unix.c caml/config.h caml/m.h caml/s.h caml/fail.h caml/misc.h \
caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \
array.d.$(O): array.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h \
- caml/spacetime.h
+ caml/spacetime.h caml/io.h caml/stack.h
backtrace.d.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/backtrace.h \
bigarray.d.$(O): bigarray.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/bigarray.h caml/custom.h caml/fail.h \
caml/intext.h caml/io.h caml/hash.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
+ caml/signals.h
callback.d.$(O): callback.c caml/callback.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/fail.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
custom.d.$(O): custom.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/custom.h caml/fail.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h
+ caml/address_class.h caml/signals.h
debugger.d.$(O): debugger.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/debugger.h caml/osdeps.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
obj.d.$(O): obj.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
caml/mlvalues.h caml/fail.h caml/gc.h caml/interp.h caml/major_gc.h \
caml/freelist.h caml/memory.h caml/minor_gc.h caml/address_class.h \
- caml/prims.h caml/spacetime.h
+ caml/prims.h caml/spacetime.h caml/io.h caml/stack.h
parsing.d.$(O): parsing.c caml/config.h caml/m.h caml/s.h caml/mlvalues.h \
caml/misc.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
caml/minor_gc.h caml/address_class.h caml/alloc.h
caml/osdeps.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
caml/minor_gc.h caml/address_class.h caml/signals.h caml/stacks.h \
caml/sys.h caml/version.h caml/callback.h caml/startup_aux.h
-terminfo.d.$(O): terminfo.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
- caml/misc.h caml/mlvalues.h caml/fail.h caml/io.h
unix.d.$(O): unix.c caml/config.h caml/m.h caml/s.h caml/fail.h caml/misc.h \
caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \
array.i.$(O): array.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h \
- caml/spacetime.h
+ caml/spacetime.h caml/io.h caml/stack.h
backtrace.i.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/backtrace.h \
bigarray.i.$(O): bigarray.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/bigarray.h caml/custom.h caml/fail.h \
caml/intext.h caml/io.h caml/hash.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
+ caml/signals.h
callback.i.$(O): callback.c caml/callback.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/fail.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
custom.i.$(O): custom.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/custom.h caml/fail.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h
+ caml/address_class.h caml/signals.h
debugger.i.$(O): debugger.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/debugger.h caml/osdeps.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
obj.i.$(O): obj.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
caml/mlvalues.h caml/fail.h caml/gc.h caml/interp.h caml/major_gc.h \
caml/freelist.h caml/memory.h caml/minor_gc.h caml/address_class.h \
- caml/prims.h caml/spacetime.h
+ caml/prims.h caml/spacetime.h caml/io.h caml/stack.h
parsing.i.$(O): parsing.c caml/config.h caml/m.h caml/s.h caml/mlvalues.h \
caml/misc.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
caml/minor_gc.h caml/address_class.h caml/alloc.h
caml/osdeps.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
caml/minor_gc.h caml/address_class.h caml/signals.h caml/stacks.h \
caml/sys.h caml/version.h caml/callback.h caml/startup_aux.h
-terminfo.i.$(O): terminfo.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
- caml/misc.h caml/mlvalues.h caml/fail.h caml/io.h
unix.i.$(O): unix.c caml/config.h caml/m.h caml/s.h caml/fail.h caml/misc.h \
caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \
array.pic.$(O): array.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h \
- caml/spacetime.h
+ caml/spacetime.h caml/io.h caml/stack.h
backtrace.pic.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/backtrace.h \
bigarray.pic.$(O): bigarray.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/bigarray.h caml/custom.h caml/fail.h \
caml/intext.h caml/io.h caml/hash.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
+ caml/signals.h
callback.pic.$(O): callback.c caml/callback.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/fail.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
custom.pic.$(O): custom.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/custom.h caml/fail.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h
+ caml/address_class.h caml/signals.h
debugger.pic.$(O): debugger.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/debugger.h caml/osdeps.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
obj.pic.$(O): obj.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
caml/mlvalues.h caml/fail.h caml/gc.h caml/interp.h caml/major_gc.h \
caml/freelist.h caml/memory.h caml/minor_gc.h caml/address_class.h \
- caml/prims.h caml/spacetime.h
+ caml/prims.h caml/spacetime.h caml/io.h caml/stack.h
parsing.pic.$(O): parsing.c caml/config.h caml/m.h caml/s.h caml/mlvalues.h \
caml/misc.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
caml/minor_gc.h caml/address_class.h caml/alloc.h
caml/osdeps.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
caml/minor_gc.h caml/address_class.h caml/signals.h caml/stacks.h \
caml/sys.h caml/version.h caml/callback.h caml/startup_aux.h
-terminfo.pic.$(O): terminfo.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
- caml/misc.h caml/mlvalues.h caml/fail.h caml/io.h
unix.pic.$(O): unix.c caml/config.h caml/m.h caml/s.h caml/fail.h caml/misc.h \
caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \
#**************************************************************************
include ../config/Makefile
-
-INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-INSTALL_INCDIR=$(INSTALL_LIBDIR)/caml
+include ../Makefile.common
# The PROGRAMS (resp. LIBRARIES) variable list the files to build and
# install as programs in $(INSTALL_BINDIR) (resp. libraries in
PROGRAMS = ocamlrun$(EXE)
LIBRARIES = ld.conf libcamlrun.$(A)
+DYNLIBRARIES=
ifeq "$(RUNTIMED)" "true"
PROGRAMS += ocamlrund$(EXE)
ifeq "$(UNIX_OR_WIN32)" "unix"
ifeq "$(SUPPORTS_SHARED_LIBRARIES)" "true"
-LIBRARIES += libcamlrun_pic.$(A) libcamlrun_shared.$(SO)
+LIBRARIES += libcamlrun_pic.$(A)
+DYNLIBRARIES += libcamlrun_shared.$(SO)
endif
endif
PRIMS=\
alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \
intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \
- signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c \
- dynlink.c backtrace_prim.c backtrace.c spacetime.c afl.c
+ signals.c str.c sys.c callback.c weak.c finalise.c stacks.c \
+ dynlink.c backtrace_prim.c backtrace.c spacetime.c afl.c \
+ bigarray.c
OBJS=$(addsuffix .$(O), \
interp misc stacks fix_code startup_aux startup \
freelist major_gc minor_gc memory alloc roots globroots \
fail signals signals_byt printexc backtrace_prim backtrace \
compare ints floats str array io extern intern \
- hash sys meta parsing gc_ctrl terminfo md5 obj \
+ hash sys meta parsing gc_ctrl md5 obj \
lexing callback debugger weak compact finalise custom \
dynlink spacetime afl $(UNIX_OR_WIN32) bigarray main)
PICOBJS=$(OBJS:.$(O)=.pic.$(O))
.PHONY: all
-all: $(LIBRARIES) $(PROGRAMS)
+all: $(LIBRARIES) $(DYNLIBRARIES) $(PROGRAMS)
ld.conf: ../config/Makefile
echo "$(STUBLIBDIR)" > $@
echo "$(LIBDIR)" >> $@
+INSTALL_INCDIR=$(INSTALL_LIBDIR)/caml
+
.PHONY: install
install:
- cp $(PROGRAMS) "$(INSTALL_BINDIR)"
- cp $(LIBRARIES) "$(INSTALL_LIBDIR)"
+ $(INSTALL_PROG) $(PROGRAMS) "$(INSTALL_BINDIR)"
+ $(INSTALL_DATA) $(LIBRARIES) "$(INSTALL_LIBDIR)"
+ if test -n "$(DYNLIBRARIES)"; then \
+ $(INSTALL_PROG) $(DYNLIBRARIES) "$(INSTALL_LIBDIR)"; \
+ fi
mkdir -p "$(INSTALL_INCDIR)"
- cp caml/*.h "$(INSTALL_INCDIR)"
+ $(INSTALL_DATA) caml/*.h "$(INSTALL_INCDIR)"
# If primitives contain duplicated lines (e.g. because the code is defined
# like
echo ' 0 };') > prims.c
caml/opnames.h : caml/instruct.h
+ cat $^ | tr -d '\r' | \
sed -e '/\/\*/d' \
-e '/^#/d' \
-e 's/enum /char * names_of_/' \
-e 's/{$$/[] = {/' \
- -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' caml/instruct.h \
- > caml/opnames.h
+ -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' > $@
# caml/jumptbl.h is required only if you have GCC 2.0 or later
caml/jumptbl.h : caml/instruct.h
+ cat $^ | tr -d '\r' | \
sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \
- -e '/^}/q' caml/instruct.h > caml/jumptbl.h
+ -e '/^}/q' > $@
caml/version.h : ../VERSION ../tools/make-version-header.sh
../tools/make-version-header.sh ../VERSION > caml/version.h
.PHONY: clean
clean:
- rm -f $(LIBRARIES) $(PROGRAMS) *.$(O) *.$(A) *.$(SO)
+ rm -f $(LIBRARIES) $(DYNLIBRARIES) $(PROGRAMS) *.$(O) *.$(A) *.$(SO)
rm -f primitives prims.c caml/opnames.h caml/jumptbl.h
rm -f caml/version.h
}
/* [len] is a number of floats */
-CAMLprim value caml_alloc_float_array(mlsize_t len)
+value caml_alloc_float_array(mlsize_t len)
{
#ifdef FLAT_FLOAT_ARRAY
mlsize_t wosize = len * Double_wosize;
/* */
/**************************************************************************/
-/* This file is an intermediate step in making the bigarray library
- (in otherlibs/bigarray) a part of the standard library.
- This file defines the basic allocation functions for bigarrays,
- as well as the comparison, hashing and marshaling methods for
- bigarrays. The other bigarray primitives are still defined
- in otherlibs/bigarray. Memory-mapping a file as a bigarray
- is being migrated to otherlibs/unix and otherlibs/win32unix. */
-
#define CAML_INTERNALS
#include <stddef.h>
#include <stdarg.h>
+#include <string.h>
#include "caml/alloc.h"
#include "caml/bigarray.h"
#include "caml/custom.h"
#include "caml/hash.h"
#include "caml/memory.h"
#include "caml/mlvalues.h"
+#include "caml/signals.h"
+
+#define int8 caml_ba_int8
+#define uint8 caml_ba_uint8
+#define int16 caml_ba_int16
+#define uint16 caml_ba_uint16
/* Compute the number of elements of a big array */
CAMLexport uintnat caml_ba_deserialize(void * dst)
{
struct caml_ba_array * b = dst;
- int i, elt_size;
- uintnat num_elts;
+ int i;
+ uintnat num_elts, size;
/* Read back header information */
b->num_dims = caml_deserialize_uint_4();
+ if (b->num_dims < 0 || b->num_dims > CAML_BA_MAX_NUM_DIMS)
+ caml_deserialize_error("input_value: wrong number of bigarray dimensions");
b->flags = caml_deserialize_uint_4() | CAML_BA_MANAGED;
b->proxy = NULL;
for (i = 0; i < b->num_dims; i++) b->dim[i] = caml_deserialize_uint_4();
- /* Compute total number of elements */
- num_elts = caml_ba_num_elts(b);
- /* Determine element size in bytes */
+ /* Compute total number of elements. Watch out for overflows (MPR#7765). */
+ num_elts = 1;
+ for (i = 0; i < b->num_dims; i++) {
+ if (caml_umul_overflow(num_elts, b->dim[i], &num_elts))
+ caml_deserialize_error("input_value: size overflow for bigarray");
+ }
+ /* Determine array size in bytes. Watch out for overflows (MPR#7765). */
if ((b->flags & CAML_BA_KIND_MASK) > CAML_BA_CHAR)
caml_deserialize_error("input_value: bad bigarray kind");
- elt_size = caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
+ if (caml_umul_overflow(num_elts,
+ caml_ba_element_size[b->flags & CAML_BA_KIND_MASK],
+ &size))
+ caml_deserialize_error("input_value: size overflow for bigarray");
/* Allocate room for data */
- b->data = malloc(elt_size * num_elts);
+ b->data = malloc(size);
if (b->data == NULL)
caml_deserialize_error("input_value: out of memory for bigarray");
/* Read data */
/* PR#5516: use C99's flexible array types if possible */
return SIZEOF_BA_ARRAY + b->num_dims * sizeof(intnat);
}
+
+/* Allocate a bigarray from OCaml */
+
+CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim)
+{
+ intnat dim[CAML_BA_MAX_NUM_DIMS];
+ mlsize_t num_dims;
+ int i, flags;
+
+ num_dims = Wosize_val(vdim);
+ /* here num_dims is unsigned (mlsize_t) so no need to check (num_dims >= 0) */
+ if (num_dims > CAML_BA_MAX_NUM_DIMS)
+ caml_invalid_argument("Bigarray.create: bad number of dimensions");
+ for (i = 0; i < num_dims; i++) {
+ dim[i] = Long_val(Field(vdim, i));
+ if (dim[i] < 0)
+ caml_invalid_argument("Bigarray.create: negative dimension");
+ }
+ flags = Caml_ba_kind_val(vkind) | Caml_ba_layout_val(vlayout);
+ return caml_ba_alloc(flags, num_dims, NULL, dim);
+}
+
+/* Given a big array and a vector of indices, check that the indices
+ are within the bounds and return the offset of the corresponding
+ array element in the data part of the array. */
+
+static long caml_ba_offset(struct caml_ba_array * b, intnat * index)
+{
+ intnat offset;
+ int i;
+
+ offset = 0;
+ if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) {
+ /* C-style layout: row major, indices start at 0 */
+ for (i = 0; i < b->num_dims; i++) {
+ if ((uintnat) index[i] >= (uintnat) b->dim[i])
+ caml_array_bound_error();
+ offset = offset * b->dim[i] + index[i];
+ }
+ } else {
+ /* Fortran-style layout: column major, indices start at 1 */
+ for (i = b->num_dims - 1; i >= 0; i--) {
+ if ((uintnat) (index[i] - 1) >= (uintnat) b->dim[i])
+ caml_array_bound_error();
+ offset = offset * b->dim[i] + (index[i] - 1);
+ }
+ }
+ return offset;
+}
+
+/* Helper function to allocate a record of two double floats */
+
+static value copy_two_doubles(double d0, double d1)
+{
+ value res = caml_alloc_small(2 * Double_wosize, Double_array_tag);
+ Store_double_field(res, 0, d0);
+ Store_double_field(res, 1, d1);
+ return res;
+}
+
+/* Generic code to read from a big array */
+
+value caml_ba_get_N(value vb, value * vind, int nind)
+{
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ intnat index[CAML_BA_MAX_NUM_DIMS];
+ int i;
+ intnat offset;
+
+ /* Check number of indices = number of dimensions of array
+ (maybe not necessary if ML typing guarantees this) */
+ if (nind != b->num_dims)
+ caml_invalid_argument("Bigarray.get: wrong number of indices");
+ /* Compute offset and check bounds */
+ for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]);
+ offset = caml_ba_offset(b, index);
+ /* Perform read */
+ switch ((b->flags) & CAML_BA_KIND_MASK) {
+ default:
+ CAMLassert(0);
+ case CAML_BA_FLOAT32:
+ return caml_copy_double(((float *) b->data)[offset]);
+ case CAML_BA_FLOAT64:
+ return caml_copy_double(((double *) b->data)[offset]);
+ case CAML_BA_SINT8:
+ return Val_int(((int8 *) b->data)[offset]);
+ case CAML_BA_UINT8:
+ return Val_int(((uint8 *) b->data)[offset]);
+ case CAML_BA_SINT16:
+ return Val_int(((int16 *) b->data)[offset]);
+ case CAML_BA_UINT16:
+ return Val_int(((uint16 *) b->data)[offset]);
+ case CAML_BA_INT32:
+ return caml_copy_int32(((int32_t *) b->data)[offset]);
+ case CAML_BA_INT64:
+ return caml_copy_int64(((int64_t *) b->data)[offset]);
+ case CAML_BA_NATIVE_INT:
+ return caml_copy_nativeint(((intnat *) b->data)[offset]);
+ case CAML_BA_CAML_INT:
+ return Val_long(((intnat *) b->data)[offset]);
+ case CAML_BA_COMPLEX32:
+ { float * p = ((float *) b->data) + offset * 2;
+ return copy_two_doubles(p[0], p[1]); }
+ case CAML_BA_COMPLEX64:
+ { double * p = ((double *) b->data) + offset * 2;
+ return copy_two_doubles(p[0], p[1]); }
+ case CAML_BA_CHAR:
+ return Val_int(((unsigned char *) b->data)[offset]);
+ }
+}
+
+CAMLprim value caml_ba_get_1(value vb, value vind1)
+{
+ return caml_ba_get_N(vb, &vind1, 1);
+}
+
+CAMLprim value caml_ba_get_2(value vb, value vind1, value vind2)
+{
+ value vind[2];
+ vind[0] = vind1; vind[1] = vind2;
+ return caml_ba_get_N(vb, vind, 2);
+}
+
+CAMLprim value caml_ba_get_3(value vb, value vind1, value vind2, value vind3)
+{
+ value vind[3];
+ vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
+ return caml_ba_get_N(vb, vind, 3);
+}
+
+CAMLprim value caml_ba_get_generic(value vb, value vind)
+{
+ return caml_ba_get_N(vb, &Field(vind, 0), Wosize_val(vind));
+}
+
+
+CAMLprim value caml_ba_uint8_get16(value vb, value vind)
+{
+ intnat res;
+ unsigned char b1, b2;
+ intnat idx = Long_val(vind);
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ if (idx < 0 || idx >= b->dim[0] - 1) caml_array_bound_error();
+ b1 = ((unsigned char*) b->data)[idx];
+ b2 = ((unsigned char*) b->data)[idx+1];
+#ifdef ARCH_BIG_ENDIAN
+ res = b1 << 8 | b2;
+#else
+ res = b2 << 8 | b1;
+#endif
+ return Val_int(res);
+}
+
+CAMLprim value caml_ba_uint8_get32(value vb, value vind)
+{
+ intnat res;
+ unsigned char b1, b2, b3, b4;
+ intnat idx = Long_val(vind);
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ if (idx < 0 || idx >= b->dim[0] - 3) caml_array_bound_error();
+ b1 = ((unsigned char*) b->data)[idx];
+ b2 = ((unsigned char*) b->data)[idx+1];
+ b3 = ((unsigned char*) b->data)[idx+2];
+ b4 = ((unsigned char*) b->data)[idx+3];
+#ifdef ARCH_BIG_ENDIAN
+ res = b1 << 24 | b2 << 16 | b3 << 8 | b4;
+#else
+ res = b4 << 24 | b3 << 16 | b2 << 8 | b1;
+#endif
+ return caml_copy_int32(res);
+}
+
+CAMLprim value caml_ba_uint8_get64(value vb, value vind)
+{
+ uint64_t res;
+ unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
+ intnat idx = Long_val(vind);
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ if (idx < 0 || idx >= b->dim[0] - 7) caml_array_bound_error();
+ b1 = ((unsigned char*) b->data)[idx];
+ b2 = ((unsigned char*) b->data)[idx+1];
+ b3 = ((unsigned char*) b->data)[idx+2];
+ b4 = ((unsigned char*) b->data)[idx+3];
+ b5 = ((unsigned char*) b->data)[idx+4];
+ b6 = ((unsigned char*) b->data)[idx+5];
+ b7 = ((unsigned char*) b->data)[idx+6];
+ b8 = ((unsigned char*) b->data)[idx+7];
+#ifdef ARCH_BIG_ENDIAN
+ res = (uint64_t) b1 << 56 | (uint64_t) b2 << 48
+ | (uint64_t) b3 << 40 | (uint64_t) b4 << 32
+ | (uint64_t) b5 << 24 | (uint64_t) b6 << 16
+ | (uint64_t) b7 << 8 | (uint64_t) b8;
+#else
+ res = (uint64_t) b8 << 56 | (uint64_t) b7 << 48
+ | (uint64_t) b6 << 40 | (uint64_t) b5 << 32
+ | (uint64_t) b4 << 24 | (uint64_t) b3 << 16
+ | (uint64_t) b2 << 8 | (uint64_t) b1;
+#endif
+ return caml_copy_int64(res);
+}
+
+/* Generic write to a big array */
+
+static value caml_ba_set_aux(value vb, value * vind, intnat nind, value newval)
+{
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ intnat index[CAML_BA_MAX_NUM_DIMS];
+ int i;
+ intnat offset;
+
+ /* Check number of indices = number of dimensions of array
+ (maybe not necessary if ML typing guarantees this) */
+ if (nind != b->num_dims)
+ caml_invalid_argument("Bigarray.set: wrong number of indices");
+ /* Compute offset and check bounds */
+ for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]);
+ offset = caml_ba_offset(b, index);
+ /* Perform write */
+ switch (b->flags & CAML_BA_KIND_MASK) {
+ default:
+ CAMLassert(0);
+ case CAML_BA_FLOAT32:
+ ((float *) b->data)[offset] = Double_val(newval); break;
+ case CAML_BA_FLOAT64:
+ ((double *) b->data)[offset] = Double_val(newval); break;
+ case CAML_BA_CHAR:
+ case CAML_BA_SINT8:
+ case CAML_BA_UINT8:
+ ((int8 *) b->data)[offset] = Int_val(newval); break;
+ case CAML_BA_SINT16:
+ case CAML_BA_UINT16:
+ ((int16 *) b->data)[offset] = Int_val(newval); break;
+ case CAML_BA_INT32:
+ ((int32_t *) b->data)[offset] = Int32_val(newval); break;
+ case CAML_BA_INT64:
+ ((int64_t *) b->data)[offset] = Int64_val(newval); break;
+ case CAML_BA_NATIVE_INT:
+ ((intnat *) b->data)[offset] = Nativeint_val(newval); break;
+ case CAML_BA_CAML_INT:
+ ((intnat *) b->data)[offset] = Long_val(newval); break;
+ case CAML_BA_COMPLEX32:
+ { float * p = ((float *) b->data) + offset * 2;
+ p[0] = Double_field(newval, 0);
+ p[1] = Double_field(newval, 1);
+ break; }
+ case CAML_BA_COMPLEX64:
+ { double * p = ((double *) b->data) + offset * 2;
+ p[0] = Double_field(newval, 0);
+ p[1] = Double_field(newval, 1);
+ break; }
+ }
+ return Val_unit;
+}
+
+CAMLprim value caml_ba_set_1(value vb, value vind1, value newval)
+{
+ return caml_ba_set_aux(vb, &vind1, 1, newval);
+}
+
+CAMLprim value caml_ba_set_2(value vb, value vind1, value vind2, value newval)
+{
+ value vind[2];
+ vind[0] = vind1; vind[1] = vind2;
+ return caml_ba_set_aux(vb, vind, 2, newval);
+}
+
+CAMLprim value caml_ba_set_3(value vb, value vind1, value vind2, value vind3,
+ value newval)
+{
+ value vind[3];
+ vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
+ return caml_ba_set_aux(vb, vind, 3, newval);
+}
+
+value caml_ba_set_N(value vb, value * vind, int nargs)
+{
+ return caml_ba_set_aux(vb, vind, nargs - 1, vind[nargs - 1]);
+}
+
+CAMLprim value caml_ba_set_generic(value vb, value vind, value newval)
+{
+ return caml_ba_set_aux(vb, &Field(vind, 0), Wosize_val(vind), newval);
+}
+
+CAMLprim value caml_ba_uint8_set16(value vb, value vind, value newval)
+{
+ unsigned char b1, b2;
+ intnat val;
+ intnat idx = Long_val(vind);
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ if (idx < 0 || idx >= b->dim[0] - 1) caml_array_bound_error();
+ val = Long_val(newval);
+#ifdef ARCH_BIG_ENDIAN
+ b1 = 0xFF & val >> 8;
+ b2 = 0xFF & val;
+#else
+ b2 = 0xFF & val >> 8;
+ b1 = 0xFF & val;
+#endif
+ ((unsigned char*) b->data)[idx] = b1;
+ ((unsigned char*) b->data)[idx+1] = b2;
+ return Val_unit;
+}
+
+CAMLprim value caml_ba_uint8_set32(value vb, value vind, value newval)
+{
+ unsigned char b1, b2, b3, b4;
+ intnat idx = Long_val(vind);
+ intnat val;
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ if (idx < 0 || idx >= b->dim[0] - 3) caml_array_bound_error();
+ val = Int32_val(newval);
+#ifdef ARCH_BIG_ENDIAN
+ b1 = 0xFF & val >> 24;
+ b2 = 0xFF & val >> 16;
+ b3 = 0xFF & val >> 8;
+ b4 = 0xFF & val;
+#else
+ b4 = 0xFF & val >> 24;
+ b3 = 0xFF & val >> 16;
+ b2 = 0xFF & val >> 8;
+ b1 = 0xFF & val;
+#endif
+ ((unsigned char*) b->data)[idx] = b1;
+ ((unsigned char*) b->data)[idx+1] = b2;
+ ((unsigned char*) b->data)[idx+2] = b3;
+ ((unsigned char*) b->data)[idx+3] = b4;
+ return Val_unit;
+}
+
+CAMLprim value caml_ba_uint8_set64(value vb, value vind, value newval)
+{
+ unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
+ intnat idx = Long_val(vind);
+ int64_t val;
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ if (idx < 0 || idx >= b->dim[0] - 7) caml_array_bound_error();
+ val = Int64_val(newval);
+#ifdef ARCH_BIG_ENDIAN
+ b1 = 0xFF & val >> 56;
+ b2 = 0xFF & val >> 48;
+ b3 = 0xFF & val >> 40;
+ b4 = 0xFF & val >> 32;
+ b5 = 0xFF & val >> 24;
+ b6 = 0xFF & val >> 16;
+ b7 = 0xFF & val >> 8;
+ b8 = 0xFF & val;
+#else
+ b8 = 0xFF & val >> 56;
+ b7 = 0xFF & val >> 48;
+ b6 = 0xFF & val >> 40;
+ b5 = 0xFF & val >> 32;
+ b4 = 0xFF & val >> 24;
+ b3 = 0xFF & val >> 16;
+ b2 = 0xFF & val >> 8;
+ b1 = 0xFF & val;
+#endif
+ ((unsigned char*) b->data)[idx] = b1;
+ ((unsigned char*) b->data)[idx+1] = b2;
+ ((unsigned char*) b->data)[idx+2] = b3;
+ ((unsigned char*) b->data)[idx+3] = b4;
+ ((unsigned char*) b->data)[idx+4] = b5;
+ ((unsigned char*) b->data)[idx+5] = b6;
+ ((unsigned char*) b->data)[idx+6] = b7;
+ ((unsigned char*) b->data)[idx+7] = b8;
+ return Val_unit;
+}
+
+/* Return the number of dimensions of a big array */
+
+CAMLprim value caml_ba_num_dims(value vb)
+{
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ return Val_long(b->num_dims);
+}
+
+/* Return the n-th dimension of a big array */
+
+CAMLprim value caml_ba_dim(value vb, value vn)
+{
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ intnat n = Long_val(vn);
+ if (n < 0 || n >= b->num_dims) caml_invalid_argument("Bigarray.dim");
+ return Val_long(b->dim[n]);
+}
+
+CAMLprim value caml_ba_dim_1(value vb)
+{
+ return caml_ba_dim(vb, Val_int(0));
+}
+
+CAMLprim value caml_ba_dim_2(value vb)
+{
+ return caml_ba_dim(vb, Val_int(1));
+}
+
+CAMLprim value caml_ba_dim_3(value vb)
+{
+ return caml_ba_dim(vb, Val_int(2));
+}
+
+/* Return the kind of a big array */
+
+CAMLprim value caml_ba_kind(value vb)
+{
+ return Val_caml_ba_kind(Caml_ba_array_val(vb)->flags & CAML_BA_KIND_MASK);
+}
+
+/* Return the layout of a big array */
+
+CAMLprim value caml_ba_layout(value vb)
+{
+ int layout = Caml_ba_array_val(vb)->flags & CAML_BA_LAYOUT_MASK;
+ return Val_caml_ba_layout(layout);
+}
+
+/* Create / update proxy to indicate that b2 is a sub-array of b1 */
+
+static void caml_ba_update_proxy(struct caml_ba_array * b1,
+ struct caml_ba_array * b2)
+{
+ struct caml_ba_proxy * proxy;
+ /* Nothing to do for un-managed arrays */
+ if ((b1->flags & CAML_BA_MANAGED_MASK) == CAML_BA_EXTERNAL) return;
+ if (b1->proxy != NULL) {
+ /* If b1 is already a proxy for a larger array, increment refcount of
+ proxy */
+ b2->proxy = b1->proxy;
+ ++ b1->proxy->refcount;
+ } else {
+ /* Otherwise, create proxy and attach it to both b1 and b2 */
+ proxy = malloc(sizeof(struct caml_ba_proxy));
+ if (proxy == NULL) caml_raise_out_of_memory();
+ proxy->refcount = 2; /* original array + sub array */
+ proxy->data = b1->data;
+ proxy->size =
+ b1->flags & CAML_BA_MAPPED_FILE ? caml_ba_byte_size(b1) : 0;
+ b1->proxy = proxy;
+ b2->proxy = proxy;
+ }
+}
+
+/* Slicing */
+
+CAMLprim value caml_ba_slice(value vb, value vind)
+{
+ CAMLparam2 (vb, vind);
+ #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
+ CAMLlocal1 (res);
+ intnat index[CAML_BA_MAX_NUM_DIMS];
+ int num_inds, i;
+ intnat offset;
+ intnat * sub_dims;
+ char * sub_data;
+
+ /* Check number of indices <= number of dimensions of array */
+ num_inds = Wosize_val(vind);
+ if (num_inds > b->num_dims)
+ caml_invalid_argument("Bigarray.slice: too many indices");
+ /* Compute offset and check bounds */
+ if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) {
+ /* We slice from the left */
+ for (i = 0; i < num_inds; i++) index[i] = Long_val(Field(vind, i));
+ for (/*nothing*/; i < b->num_dims; i++) index[i] = 0;
+ offset = caml_ba_offset(b, index);
+ sub_dims = b->dim + num_inds;
+ } else {
+ /* We slice from the right */
+ for (i = 0; i < num_inds; i++)
+ index[b->num_dims - num_inds + i] = Long_val(Field(vind, i));
+ for (i = 0; i < b->num_dims - num_inds; i++) index[i] = 1;
+ offset = caml_ba_offset(b, index);
+ sub_dims = b->dim;
+ }
+ sub_data =
+ (char *) b->data +
+ offset * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
+ /* Allocate an OCaml bigarray to hold the result */
+ res = caml_ba_alloc(b->flags, b->num_dims - num_inds, sub_data, sub_dims);
+ /* Create or update proxy in case of managed bigarray */
+ caml_ba_update_proxy(b, Caml_ba_array_val(res));
+ /* Return result */
+ CAMLreturn (res);
+
+ #undef b
+}
+
+/* Changing the layout of an array (memory is shared) */
+
+CAMLprim value caml_ba_change_layout(value vb, value vlayout)
+{
+ CAMLparam2 (vb, vlayout);
+ CAMLlocal1 (res);
+ #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
+ /* if the layout is different, change the flags and reverse the dimensions */
+ if (Caml_ba_layout_val(vlayout) != (b->flags & CAML_BA_LAYOUT_MASK)) {
+ /* change the flags to reflect the new layout */
+ int flags = (b->flags & (CAML_BA_KIND_MASK | CAML_BA_MANAGED_MASK))
+ | Caml_ba_layout_val(vlayout);
+ /* reverse the dimensions */
+ intnat new_dim[CAML_BA_MAX_NUM_DIMS];
+ unsigned int i;
+ for(i = 0; i < b->num_dims; i++) new_dim[i] = b->dim[b->num_dims - i - 1];
+ res = caml_ba_alloc(flags, b->num_dims, b->data, new_dim);
+ caml_ba_update_proxy(b, Caml_ba_array_val(res));
+ CAMLreturn(res);
+ } else {
+ /* otherwise, do nothing */
+ CAMLreturn(vb);
+ }
+ #undef b
+}
+
+
+/* Extracting a sub-array of same number of dimensions */
+
+CAMLprim value caml_ba_sub(value vb, value vofs, value vlen)
+{
+ CAMLparam3 (vb, vofs, vlen);
+ CAMLlocal1 (res);
+ #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
+ intnat ofs = Long_val(vofs);
+ intnat len = Long_val(vlen);
+ int i, changed_dim;
+ intnat mul;
+ char * sub_data;
+
+ /* Compute offset and check bounds */
+ if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) {
+ /* We reduce the first dimension */
+ mul = 1;
+ for (i = 1; i < b->num_dims; i++) mul *= b->dim[i];
+ changed_dim = 0;
+ } else {
+ /* We reduce the last dimension */
+ mul = 1;
+ for (i = 0; i < b->num_dims - 1; i++) mul *= b->dim[i];
+ changed_dim = b->num_dims - 1;
+ ofs--; /* Fortran arrays start at 1 */
+ }
+ if (ofs < 0 || len < 0 || ofs + len > b->dim[changed_dim])
+ caml_invalid_argument("Bigarray.sub: bad sub-array");
+ sub_data =
+ (char *) b->data +
+ ofs * mul * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
+ /* Allocate an OCaml bigarray to hold the result */
+ res = caml_ba_alloc(b->flags, b->num_dims, sub_data, b->dim);
+ /* Doctor the changed dimension */
+ Caml_ba_array_val(res)->dim[changed_dim] = len;
+ /* Create or update proxy in case of managed bigarray */
+ caml_ba_update_proxy(b, Caml_ba_array_val(res));
+ /* Return result */
+ CAMLreturn (res);
+
+ #undef b
+}
+
+/* Copying a big array into another one */
+
+#define LEAVE_RUNTIME_OP_CUTOFF 4096
+#define is_mmapped(ba) ((ba)->flags & CAML_BA_MAPPED_FILE)
+
+CAMLprim value caml_ba_blit(value vsrc, value vdst)
+{
+ CAMLparam2(vsrc, vdst);
+ struct caml_ba_array * src = Caml_ba_array_val(vsrc);
+ struct caml_ba_array * dst = Caml_ba_array_val(vdst);
+ void *src_data = src->data;
+ void *dst_data = dst->data;
+ int i;
+ intnat num_bytes;
+ int leave_runtime;
+
+ /* Check same numbers of dimensions and same dimensions */
+ if (src->num_dims != dst->num_dims) goto blit_error;
+ for (i = 0; i < src->num_dims; i++)
+ if (src->dim[i] != dst->dim[i]) goto blit_error;
+ /* Compute number of bytes in array data */
+ num_bytes =
+ caml_ba_num_elts(src)
+ * caml_ba_element_size[src->flags & CAML_BA_KIND_MASK];
+ leave_runtime =
+ (
+ (num_bytes >= LEAVE_RUNTIME_OP_CUTOFF*sizeof(long))
+ || is_mmapped(src)
+ || is_mmapped(dst)
+ );
+ /* Do the copying */
+ if (leave_runtime) caml_enter_blocking_section();
+ memmove (dst_data, src_data, num_bytes);
+ if (leave_runtime) caml_leave_blocking_section();
+ CAMLreturn (Val_unit);
+ blit_error:
+ caml_invalid_argument("Bigarray.blit: dimension mismatch");
+ CAMLreturn (Val_unit); /* not reached */
+}
+
+/* Filling a big array with a given value */
+
+#define FILL_GEN_LOOP(n_ops, loop) do{ \
+ int leave_runtime = ((n_ops >= LEAVE_RUNTIME_OP_CUTOFF) || is_mmapped(b)); \
+ if (leave_runtime) caml_enter_blocking_section(); \
+ loop; \
+ if (leave_runtime) caml_leave_blocking_section(); \
+}while(0)
+
+#define FILL_SCALAR_LOOP \
+ FILL_GEN_LOOP(num_elts, \
+ for (p = data; num_elts > 0; p++, num_elts--) *p = init)
+
+#define FILL_COMPLEX_LOOP \
+ FILL_GEN_LOOP(num_elts + num_elts, \
+ for (p = data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; })
+
+CAMLprim value caml_ba_fill(value vb, value vinit)
+{
+ CAMLparam1(vb);
+ struct caml_ba_array * b = Caml_ba_array_val(vb);
+ void *data = b->data;
+ intnat num_elts = caml_ba_num_elts(b);
+
+ switch (b->flags & CAML_BA_KIND_MASK) {
+ default:
+ CAMLassert(0);
+ case CAML_BA_FLOAT32: {
+ float init = Double_val(vinit);
+ float * p;
+ FILL_SCALAR_LOOP;
+ break;
+ }
+ case CAML_BA_FLOAT64: {
+ double init = Double_val(vinit);
+ double * p;
+ FILL_SCALAR_LOOP;
+ break;
+ }
+ case CAML_BA_CHAR:
+ case CAML_BA_SINT8:
+ case CAML_BA_UINT8: {
+ int init = Int_val(vinit);
+ unsigned char * p;
+ FILL_SCALAR_LOOP;
+ break;
+ }
+ case CAML_BA_SINT16:
+ case CAML_BA_UINT16: {
+ int init = Int_val(vinit);
+ int16 * p;
+ FILL_SCALAR_LOOP;
+ break;
+ }
+ case CAML_BA_INT32: {
+ int32_t init = Int32_val(vinit);
+ int32_t * p;
+ FILL_SCALAR_LOOP;
+ break;
+ }
+ case CAML_BA_INT64: {
+ int64_t init = Int64_val(vinit);
+ int64_t * p;
+ FILL_SCALAR_LOOP;
+ break;
+ }
+ case CAML_BA_NATIVE_INT: {
+ intnat init = Nativeint_val(vinit);
+ intnat * p;
+ FILL_SCALAR_LOOP;
+ break;
+ }
+ case CAML_BA_CAML_INT: {
+ intnat init = Long_val(vinit);
+ intnat * p;
+ FILL_SCALAR_LOOP;
+ break;
+ }
+ case CAML_BA_COMPLEX32: {
+ float init0 = Double_field(vinit, 0);
+ float init1 = Double_field(vinit, 1);
+ float * p;
+ FILL_COMPLEX_LOOP;
+ break;
+ }
+ case CAML_BA_COMPLEX64: {
+ double init0 = Double_field(vinit, 0);
+ double init1 = Double_field(vinit, 1);
+ double * p;
+ FILL_COMPLEX_LOOP;
+ break;
+ }
+ }
+ CAMLreturn (Val_unit);
+}
+
+/* Reshape an array: change dimensions and number of dimensions, preserving
+ array contents */
+
+CAMLprim value caml_ba_reshape(value vb, value vdim)
+{
+ CAMLparam2 (vb, vdim);
+ CAMLlocal1 (res);
+#define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
+ intnat dim[CAML_BA_MAX_NUM_DIMS];
+ mlsize_t num_dims;
+ uintnat num_elts;
+ int i;
+
+ num_dims = Wosize_val(vdim);
+ /* here num_dims is unsigned (mlsize_t) so no need to check (num_dims >= 0) */
+ if (num_dims > CAML_BA_MAX_NUM_DIMS)
+ caml_invalid_argument("Bigarray.reshape: bad number of dimensions");
+ num_elts = 1;
+ for (i = 0; i < num_dims; i++) {
+ dim[i] = Long_val(Field(vdim, i));
+ if (dim[i] < 0)
+ caml_invalid_argument("Bigarray.reshape: negative dimension");
+ num_elts *= dim[i];
+ }
+ /* Check that sizes agree */
+ if (num_elts != caml_ba_num_elts(b))
+ caml_invalid_argument("Bigarray.reshape: size mismatch");
+ /* Create bigarray with same data and new dimensions */
+ res = caml_ba_alloc(b->flags, num_dims, b->data, dim);
+ /* Create or update proxy in case of managed bigarray */
+ caml_ba_update_proxy(b, Caml_ba_array_val(res));
+ /* Return result */
+ CAMLreturn (res);
+
+#undef b
+}
#include "compatibility.h"
#endif
+#include <stddef.h>
+
#ifdef HAS_STDINT_H
#include <stdint.h>
#endif
/* Magic number for this release */
-#define EXEC_MAGIC "Caml1999X011"
+#define EXEC_MAGIC "Caml1999X023"
#endif /* CAML_INTERNALS */
GETFIELD0, GETFIELD1, GETFIELD2, GETFIELD3, GETFIELD, GETFLOATFIELD,
SETFIELD0, SETFIELD1, SETFIELD2, SETFIELD3, SETFIELD, SETFLOATFIELD,
VECTLENGTH, GETVECTITEM, SETVECTITEM,
- GETSTRINGCHAR, SETSTRINGCHAR,
+ GETBYTESCHAR, SETBYTESCHAR,
BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, BOOLNOT,
PUSHTRAP, POPTRAP, RAISE,
CHECK_SIGNALS,
STOP,
EVENT, BREAK,
RERAISE, RAISE_NOTRACE,
+ GETSTRINGCHAR,
FIRST_UNIMPLEMENTED_OP};
#endif /* CAML_INTERNALS */
CAMLextern struct code_fragment * caml_extern_find_code(char *addr);
-struct ext_table caml_code_fragments_table;
+extern struct ext_table caml_code_fragments_table;
#endif /* CAML_INTERNALS */
extern char *caml_gc_sweep_hp;
extern int caml_major_window;
-double caml_major_ring[Max_major_window];
-int caml_major_ring_index;
-double caml_major_work_credit;
+extern double caml_major_ring[Max_major_window];
+extern int caml_major_ring_index;
+extern double caml_major_work_credit;
extern double caml_gc_clock;
/* [caml_major_gc_hook] is called just between the end of the mark
CAMLextern value *caml_young_trigger;
extern asize_t caml_minor_heap_wsz;
extern int caml_in_minor_collection;
+extern double caml_extra_heap_resources_minor;
#define CAML_TABLE_STRUCT(t) { \
t *base; \
#define rename_os caml_win32_rename
#define chdir_os _wchdir
#define getcwd_os _wgetcwd
-#define getenv_os _wgetenv
#define system_os _wsystem
#define rmdir_os _wrmdir
-#define utime_os _wutime
#define putenv_os _wputenv
#define chmod_os _wchmod
#define execv_os _wexecv
#define rename_os rename
#define chdir_os chdir
#define getcwd_os getcwd
-#define getenv_os getenv
#define system_os system
#define rmdir_os rmdir
-#define utime_os utime
#define putenv_os putenv
#define chmod_os chmod
#define execv_os execv
#define CAML_SYS_UNLINK(filename) unlink_os(filename)
#define CAML_SYS_RENAME(old_name,new_name) rename_os(old_name, new_name)
#define CAML_SYS_CHDIR(dirname) chdir_os(dirname)
-#define CAML_SYS_GETENV(varname) getenv_os(varname)
+#define CAML_SYS_GETENV(varname) getenv(varname)
#define CAML_SYS_SYSTEM(command) system_os(command)
#define CAML_SYS_READ_DIRECTORY(dirname,tbl) caml_read_directory(dirname,tbl)
#define CAML_SYS_CHDIR(dirname) \
CAML_SYS_PRIM_1(CAML_CPLUGINS_CHDIR,chdir_os,dirname)
#define CAML_SYS_GETENV(varname) \
- CAML_SYS_STRING_PRIM_1(CAML_CPLUGINS_GETENV,getenv_os,varname)
+ CAML_SYS_STRING_PRIM_1(CAML_CPLUGINS_GETENV,getenv,varname)
#define CAML_SYS_SYSTEM(command) \
CAML_SYS_PRIM_1(CAML_CPLUGINS_SYSTEM,system_os,command)
#define CAML_SYS_READ_DIRECTORY(dirname,tbl) \
*/
extern char_os *caml_secure_getenv(char_os const *var);
+/* If [fd] refers to a terminal or console, return the number of rows
+ (lines) that it displays. Otherwise, or if the number of rows
+ cannot be determined, return -1. */
+extern int caml_num_rows_fd(int fd);
+
#ifdef _WIN32
extern int caml_win32_rename(const wchar_t *, const wchar_t *);
extern void caml_setup_win32_terminal(void);
extern void caml_restore_win32_terminal(void);
+extern wchar_t *caml_win32_getenv(wchar_t const *);
+
/* Windows Unicode support */
extern int win_multi_byte_to_wide_char(const char* s, int slen, wchar_t *out, int outlen);
*/
extern value caml_copy_string_of_utf16(const wchar_t *s);
+extern int caml_win32_isatty(int fd);
+
#endif /* _WIN32 */
#endif /* CAML_INTERNALS */
#ifndef CAML_SPACETIME_H
#define CAML_SPACETIME_H
-#ifdef NATIVE_CODE
-
-#include "caml/io.h"
-#include "caml/misc.h"
-#include "caml/stack.h"
+#include "io.h"
+#include "misc.h"
+#include "stack.h"
/* Runtime support for Spacetime profiling.
* This header file is not intended for the casual user.
#define Get_my_profinfo_with_cached_backtrace(profinfo, size) \
profinfo = (uintnat) 0;
-#endif /* NATIVE_CODE */
-
-
#endif
#include "caml/fail.h"
#include "caml/memory.h"
#include "caml/mlvalues.h"
+#include "caml/signals.h"
/* [size] is a number of bytes */
CAMLexport value caml_alloc_custom(struct custom_operations * ops,
mlsize_t max)
{
mlsize_t wosize;
- value result;
+ CAMLparam0();
+ CAMLlocal1(result);
wosize = 1 + (size + sizeof(value) - 1) / sizeof(value);
if (wosize <= Max_young_wosize) {
if (ops->finalize != NULL || mem != 0) {
/* Remember that the block needs processing after minor GC. */
add_to_custom_table (&caml_custom_table, result, mem, max);
+ /* Keep track of extra resources held by custom block in
+ minor heap. */
+ if (mem != 0) {
+ if (max == 0) max = 1;
+ caml_extra_heap_resources_minor += (double) mem / (double) max;
+ if (caml_extra_heap_resources_minor > 1.0) {
+ caml_request_minor_gc ();
+ caml_gc_dispatch ();
+ }
+ }
}
} else {
result = caml_alloc_shr(wosize, Custom_tag);
caml_adjust_gc_speed(mem, max);
result = caml_check_urgent_gc(result);
}
- return result;
+ CAMLreturn(result);
}
struct custom_operations_list {
{
char * address;
char_os * a;
+ size_t a_len;
char * port, * p;
struct hostent * host;
int n;
/* Unix domain */
sock_domain = PF_UNIX;
sock_addr.s_unix.sun_family = AF_UNIX;
+ a_len = strlen(address);
+ if (a_len >= sizeof(sock_addr.s_unix.sun_path)) {
+ caml_fatal_error("Debug socket path length exceeds maximum permitted length");
+ }
strncpy(sock_addr.s_unix.sun_path, address,
- sizeof(sock_addr.s_unix.sun_path));
+ sizeof(sock_addr.s_unix.sun_path) - 1);
+ sock_addr.s_unix.sun_path[sizeof(sock_addr.s_unix.sun_path) - 1] = '\0';
sock_addr_len =
((char *)&(sock_addr.s_unix.sun_path) - (char *)&(sock_addr.s_unix))
- + strlen(address);
+ + a_len;
#else
caml_fatal_error("Unix sockets not supported");
#endif
CAMLreturn (Val_unit);
}
-CAMLprim value caml_output_value_to_string(value v, value flags)
+CAMLprim value caml_output_value_to_bytes(value v, value flags)
{
char header[32];
int header_len;
return res;
}
+CAMLprim value caml_output_value_to_string(value v, value flags)
+{
+ return caml_output_value_to_bytes(v,flags);
+}
+
CAMLexport intnat caml_output_value_to_block(value v, value flags,
char * buf, intnat len)
{
CAMLassert (Is_block (final->table[i].val));
CAMLassert (Is_in_heap_or_young (final->table[i].val));
CAMLassert (Tag_val (final->table[i].val) != Forward_tag);
- if(Is_young(final->table[j].val) && Hd_val(final->table[i].val) != 0){
+ if(Is_young(final->table[i].val) && Hd_val(final->table[i].val) != 0){
/** dead */
to_do_tl->item[k] = final->table[i];
/* The finalisation function is called with unit not with the value */
code_t caml_start_code;
asize_t caml_code_size;
unsigned char * caml_saved_code;
+struct ext_table caml_code_fragments_table;
/* Read the main bytecode block from a file */
if (*s == 0) return -1; /* nothing after exponent mark */
e = strtol(s, &p, 10);
if (*p != 0) return -1; /* ill-formed exponent */
- if (e < INT_MIN || e > INT_MAX) return -1; /* unreasonable exponent */
+ /* Handle exponents larger than int by returning 0/∞ directly.
+ Mind that INT_MIN/INT_MAX are included in the test so as to capture
+ the overflow case of strtol on Win64 — long and int have the same
+ size there. */
+ if (e <= INT_MIN) {
+ *res = 0.;
+ return 0;
+ }
+ else if (e >= INT_MAX) {
+ *res = m == 0 ? 0. : HUGE_VAL;
+ return 0;
+ }
+ /* regular exponent value */
exp = e;
s = p; /* stop at next loop iteration */
break;
on several architectures. */
f = (double) (int64_t) m;
/* Adjust exponent to take decimal point and extra digits into account */
- if (dec_point >= 0) exp = exp + (dec_point - n_bits);
- exp = exp + x_bits;
+ {
+ int adj = x_bits;
+ if (dec_point >= 0) adj = adj + (dec_point - n_bits);
+ /* saturated addition exp + adj */
+ if (adj > 0 && exp > INT_MAX - adj)
+ exp = INT_MAX;
+ else if (adj < 0 && exp < INT_MIN - adj)
+ exp = INT_MIN;
+ else
+ exp = exp + adj;
+ }
/* Apply exponent if needed */
if (exp != 0) f = ldexp(f, exp);
/* Done! */
*/
void caml_fl_add_blocks (value bp)
{
+ value cur = bp;
CAMLassert (fl_last != Val_NULL);
CAMLassert (Next (fl_last) == Val_NULL);
- caml_fl_cur_wsz += Whsize_bp (bp);
+ do {
+ caml_fl_cur_wsz += Whsize_bp (cur);
+ cur = Field(cur, 0);
+ } while (cur != Val_NULL);
if (bp > fl_last){
Next (fl_last) = bp;
flp [flp_size++] = fl_last;
}
}else{
- value cur, prev;
+ value prev;
prev = Fl_head;
cur = Next (prev);
CAMLreturn (res);
}
-CAMLexport value caml_input_val_from_string(value str, intnat ofs)
+CAMLexport value caml_input_val_from_bytes(value str, intnat ofs)
{
CAMLparam1 (str);
CAMLlocal1 (obj);
CAMLprim value caml_input_value_from_string(value str, value ofs)
{
- return caml_input_val_from_string(str, Long_val(ofs));
+ return caml_input_val_from_bytes(str, Long_val(ofs));
+}
+
+CAMLprim value caml_input_value_from_bytes(value str, value ofs)
+{
+ return caml_input_val_from_bytes(str, Long_val(ofs));
}
static value input_val_from_block(struct marshal_header * h)
sp += 2;
Next;
-/* String operations */
-
+/* Bytes/String operations */
Instruct(GETSTRINGCHAR):
+ Instruct(GETBYTESCHAR):
accu = Val_int(Byte_u(accu, Long_val(sp[0])));
sp += 1;
Next;
- Instruct(SETSTRINGCHAR):
+ Instruct(SETBYTESCHAR):
Byte_u(accu, Long_val(sp[0])) = Int_val(sp[1]);
sp += 2;
accu = Val_unit;
Instruct(LSLINT):
accu = (value)((((intnat) accu - 1) << Long_val(*sp++)) + 1); Next;
Instruct(LSRINT):
- accu = (value)((((uintnat) accu - 1) >> Long_val(*sp++)) | 1);
- Next;
+ accu = (value)((((uintnat) accu) >> Long_val(*sp++)) | 1); Next;
Instruct(ASRINT):
- accu = (value)((((intnat) accu - 1) >> Long_val(*sp++)) | 1); Next;
+ accu = (value)((((intnat) accu) >> Long_val(*sp++)) | 1); Next;
#define Integer_comparison(typ,opname,tst) \
Instruct(opname): \
default:
caml_deserialize_error("input_value: ill-formed native integer");
}
- return sizeof(long);
+ return sizeof(intnat);
}
CAMLexport struct custom_operations caml_nativeint_ops = {
Unlock(channel);
CAMLreturn (Val_long(res));
}
+
+CAMLprim value caml_terminfo_rows(value vchannel)
+{
+ return Val_int(caml_num_rows_fd(Channel(vchannel)->fd));
+}
#endif
struct pool_block *next;
struct pool_block *prev;
- union max_align data[1]; /* not allocated, used for alignment purposes */
+ /* Use C99's flexible array types if possible */
+#if (__STDC_VERSION__ >= 199901L)
+ union max_align data[]; /* not allocated, used for alignment purposes */
+#else
+ union max_align data[1];
+#endif
};
+#if (__STDC_VERSION__ >= 199901L)
+#define SIZEOF_POOL_BLOCK sizeof(struct pool_block)
+#else
#define SIZEOF_POOL_BLOCK offsetof(struct pool_block, data)
+#endif
static struct pool_block *pool = NULL;
int caml_in_minor_collection = 0;
+double caml_extra_heap_resources_minor = 0;
+
/* [sz] and [rsv] are numbers of entries */
static void alloc_generic_table (struct generic_table *tbl, asize_t sz,
asize_t rsv, asize_t element_size)
clear_table ((struct generic_table *) &caml_ref_table);
clear_table ((struct generic_table *) &caml_ephe_ref_table);
clear_table ((struct generic_table *) &caml_custom_table);
+ caml_extra_heap_resources_minor = 0;
caml_gc_message (0x02, ">");
caml_in_minor_collection = 0;
caml_final_empty_young ();
void* saved_spacetime_trie_node_ptr;
#endif
#ifdef POSIX_SIGNALS
- sigset_t sigs;
+ sigset_t nsigs, sigs;
/* Block the signal before executing the handler, and record in sigs
the original signal mask */
- sigemptyset(&sigs);
- sigaddset(&sigs, signal_number);
- sigprocmask(SIG_BLOCK, &sigs, &sigs);
+ sigemptyset(&nsigs);
+ sigaddset(&nsigs, signal_number);
+ sigprocmask(SIG_BLOCK, &nsigs, &sigs);
#endif
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
/* We record the signal handler's execution separately, in the same
return Val_int(res);
}
+CAMLprim value caml_bytes_get16(value str, value index)
+{
+ return caml_string_get16(str,index);
+}
+
CAMLprim value caml_string_get32(value str, value index)
{
intnat res;
return caml_copy_int32(res);
}
+CAMLprim value caml_bytes_get32(value str, value index)
+{
+ return caml_string_get32(str,index);
+}
+
CAMLprim value caml_string_get64(value str, value index)
{
uint64_t res;
return caml_copy_int64(res);
}
-CAMLprim value caml_string_set16(value str, value index, value newval)
+CAMLprim value caml_bytes_get64(value str, value index)
+{
+ return caml_string_get64(str,index);
+}
+
+CAMLprim value caml_bytes_set16(value str, value index, value newval)
{
unsigned char b1, b2;
intnat val;
return Val_unit;
}
-CAMLprim value caml_string_set32(value str, value index, value newval)
+CAMLprim value caml_bytes_set32(value str, value index, value newval)
{
unsigned char b1, b2, b3, b4;
intnat val;
return Val_unit;
}
-CAMLprim value caml_string_set64(value str, value index, value newval)
+CAMLprim value caml_bytes_set64(value str, value index, value newval)
{
unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
int64_t val;
return caml_fill_bytes (s, offset, len, init);
}
-CAMLprim value caml_bitvect_test(value bv, value n)
-{
- intnat pos = Long_val(n);
- return Val_int(Byte_u(bv, pos >> 3) & (1 << (pos & 7)));
-}
-
CAMLexport value caml_alloc_sprintf(const char * format, ...)
{
va_list args;
return res;
#endif
}
+
+CAMLprim value caml_string_of_bytes(value bv)
+{
+ return bv;
+}
+
+CAMLprim value caml_bytes_of_string(value bv)
+{
+ return bv;
+}
#include <sys/types.h>
#include <sys/stat.h>
#ifdef _WIN32
-#include <io.h> /* for isatty */
#include <direct.h> /* for _wchdir and _wgetcwd */
#else
#include <sys/wait.h>
CAMLprim value caml_sys_unsafe_getenv(value var)
{
char_os * res, * p;
+ value val;
if (! caml_string_is_c_safe(var)) caml_raise_not_found();
p = caml_stat_strdup_to_os(String_val(var));
+#ifdef _WIN32
+ res = caml_win32_getenv(p);
+#else
res = CAML_SYS_GETENV(p);
+#endif
caml_stat_free(p);
if (res == 0) caml_raise_not_found();
- return caml_copy_string_of_os(res);
+ val = caml_copy_string_of_os(res);
+#ifdef _WIN32
+ caml_stat_free(res);
+#endif
+ return val;
}
CAMLprim value caml_sys_getenv(value var)
{
char_os * res, * p;
+ value val;
if (! caml_string_is_c_safe(var)) caml_raise_not_found();
p = caml_stat_strdup_to_os(String_val(var));
+#ifdef _WIN32
+ res = caml_win32_getenv(p);
+#else
res = caml_secure_getenv(p);
+#endif
caml_stat_free(p);
if (res == 0) caml_raise_not_found();
- return caml_copy_string_of_os(res);
+ val = caml_copy_string_of_os(res);
+#ifdef _WIN32
+ caml_stat_free(res);
+#endif
+ return val;
}
char_os * caml_exe_name;
fd = (Channel(chan))->fd;
#ifdef _WIN32
- ret = Val_bool(_isatty(fd));
- /* https://msdn.microsoft.com/en-us/library/f4s0ddew.aspx */
+ ret = Val_bool(caml_win32_isatty(fd));
#else
ret = Val_bool(isatty(fd));
#endif
+++ /dev/null
-/**************************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. */
-/* */
-/* All rights reserved. This file is distributed under the terms of */
-/* the GNU Lesser General Public License version 2.1, with the */
-/* special exception on linking described in the file LICENSE. */
-/* */
-/**************************************************************************/
-
-#define CAML_INTERNALS
-
-/* Read and output terminal commands */
-
-#include "caml/config.h"
-#include "caml/alloc.h"
-#include "caml/fail.h"
-#include "caml/io.h"
-#include "caml/mlvalues.h"
-
-#define Uninitialised (Val_int(0))
-#define Bad_term (Val_int(1))
-#define Good_term_tag 0
-
-#if defined (HAS_TERMCAP) && !defined (NATIVE_CODE)
-
-extern int tgetent (char * buffer, char * name);
-extern char * tgetstr (char * id, char ** area);
-extern int tgetnum (char * id);
-extern int tputs (char * str, int count, int (*outchar)(int c));
-
-static struct channel *chan;
-static char area [1024];
-static char *area_p = area;
-static int num_lines;
-static char *up = NULL;
-static char *down = NULL;
-static char *standout = NULL;
-static char *standend = NULL;
-
-CAMLprim value caml_terminfo_setup (value vchan)
-{
- value result;
- static char buffer[1024];
- char *term;
-
- chan = Channel (vchan);
-
- term = getenv ("TERM");
- if (term == NULL) return Bad_term;
- if (tgetent(buffer, term) != 1) return Bad_term;
-
- num_lines = tgetnum ("li");
- up = tgetstr ("up", &area_p);
- down = tgetstr ("do", &area_p);
- standout = tgetstr ("us", &area_p);
- standend = tgetstr ("ue", &area_p);
- if (standout == NULL || standend == NULL){
- standout = tgetstr ("so", &area_p);
- standend = tgetstr ("se", &area_p);
- }
- CAMLassert (area_p <= area + 1024);
- if (num_lines == -1 || up == NULL || down == NULL
- || standout == NULL || standend == NULL){
- return Bad_term;
- }
- result = caml_alloc_small (1, Good_term_tag);
- Field (result, 0) = Val_int (num_lines);
- return result;
-}
-
-static int terminfo_putc (int c)
-{
- caml_putch (chan, c);
- return c;
-}
-
-CAMLprim value caml_terminfo_backup (value lines)
-{
- int i;
-
- for (i = 0; i < Int_val (lines); i++){
- tputs (up, 1, terminfo_putc);
- }
- return Val_unit;
-}
-
-CAMLprim value caml_terminfo_standout (value start)
-{
- tputs (Bool_val (start) ? standout : standend, 1, terminfo_putc);
- return Val_unit;
-}
-
-CAMLprim value caml_terminfo_resume (value lines)
-{
- int i;
-
- for (i = 0; i < Int_val (lines); i++){
- tputs (down, 1, terminfo_putc);
- }
- return Val_unit;
-}
-
-#else /* defined (HAS_TERMCAP) && !defined (NATIVE_CODE) */
-
-CAMLexport value caml_terminfo_setup (value vchan)
-{
- return Bad_term;
-}
-
-CAMLexport value caml_terminfo_backup (value lines)
-{
- caml_invalid_argument("Terminfo.backup");
- return Val_unit;
-}
-
-CAMLexport value caml_terminfo_standout (value start)
-{
- caml_invalid_argument("Terminfo.standout");
- return Val_unit;
-}
-
-CAMLexport value caml_terminfo_resume (value lines)
-{
- caml_invalid_argument("Terminfo.resume");
- return Val_unit;
-}
-
-#endif /* defined (HAS_TERMCAP) && !defined (NATIVE_CODE) */
#include <sys/types.h>
#include <sys/stat.h>
#include <errno.h>
+#include <sys/ioctl.h>
#include <fcntl.h>
#include "caml/config.h"
#ifdef SUPPORT_DYNAMIC_LINKING
static int cygwin_file_exists(const char * name)
{
- int fd;
+ int fd, ret;
+ struct stat st;
/* Cannot use stat() here because it adds ".exe" implicitly */
fd = open(name, O_RDONLY);
if (fd == -1) return 0;
+ ret = fstat(fd, &st);
close(fd);
- return 1;
+ return ret == 0 && S_ISREG(st.st_mode);
}
static caml_stat_string cygwin_search_exe_in_path(struct ext_table * path, const char * name)
return NULL;
#endif
}
+
+int caml_num_rows_fd(int fd)
+{
+#ifdef TIOCGWINSZ
+ struct winsize w;
+ w.ws_row = -1;
+ if (ioctl(fd, TIOCGWINSZ, &w) == 0)
+ return w.ws_row;
+ else
+ return -1;
+#else
+ return -1;
+#endif
+}
+
+
mlsize_t size, i;
value res;
- size = Long_val (len) + 1 /* weak_list */ + 1 /* the value */;
- if (size <= 0 || size > Max_wosize) caml_invalid_argument ("Weak.create");
+ size = Long_val (len) + CAML_EPHE_FIRST_KEY;
+ if (size < CAML_EPHE_FIRST_KEY || size > Max_wosize)
+ caml_invalid_argument ("Weak.create");
res = caml_alloc_shr (size, Abstract_tag);
for (i = 1; i < size; i++) Field (res, i) = caml_ephe_none;
Field (res, CAML_EPHE_LINK_OFFSET) = caml_ephe_list_head;
that is going to disappear is dead and so should trigger a cleaning
*/
static void do_check_key_clean(value ar, mlsize_t offset){
- CAMLassert ( offset >= 2);
+ CAMLassert (offset >= CAML_EPHE_FIRST_KEY);
if (caml_gc_phase == Phase_clean){
value elt = Field (ar, offset);
if (elt != caml_ephe_none && Is_Dead_during_clean(elt)){
CAMLprim value caml_ephe_set_key (value ar, value n, value el)
{
- mlsize_t offset = Long_val (n) + 2;
+ mlsize_t offset = Long_val (n) + CAML_EPHE_FIRST_KEY;
CAMLassert (Is_in_heap (ar));
- if (offset < 2 || offset >= Wosize_val (ar)){
+ if (offset < CAML_EPHE_FIRST_KEY || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.set");
}
do_check_key_clean(ar,offset);
CAMLprim value caml_ephe_unset_key (value ar, value n)
{
- mlsize_t offset = Long_val (n) + 2;
+ mlsize_t offset = Long_val (n) + CAML_EPHE_FIRST_KEY;
CAMLassert (Is_in_heap (ar));
- if (offset < 2 || offset >= Wosize_val (ar)){
+ if (offset < CAML_EPHE_FIRST_KEY || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.set");
}
do_check_key_clean(ar,offset);
value caml_ephe_set_key_option (value ar, value n, value el)
{
- mlsize_t offset = Long_val (n) + 2;
+ mlsize_t offset = Long_val (n) + CAML_EPHE_FIRST_KEY;
CAMLassert (Is_in_heap (ar));
- if (offset < 2 || offset >= Wosize_val (ar)){
+ if (offset < CAML_EPHE_FIRST_KEY || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.set");
}
do_check_key_clean(ar,offset);
cleaned we always need to check it. */
caml_ephe_clean(ar);
};
- do_set (ar, 1, el);
+ do_set (ar, CAML_EPHE_DATA_OFFSET, el);
return Val_unit;
}
CAMLprim value caml_ephe_get_key (value ar, value n)
{
CAMLparam2 (ar, n);
- mlsize_t offset = Long_val (n) + 2;
+ mlsize_t offset = Long_val (n) + CAML_EPHE_FIRST_KEY;
CAMLlocal2 (res, elt);
CAMLassert (Is_in_heap (ar));
- if (offset < 2 || offset >= Wosize_val (ar)){
+ if (offset < CAML_EPHE_FIRST_KEY || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.get_key");
}
if (is_ephe_key_none(ar, offset)){
CAMLprim value caml_ephe_get_data (value ar)
{
CAMLparam1 (ar);
- mlsize_t offset = 1;
CAMLlocal2 (res, elt);
CAMLassert (Is_in_heap (ar));
- elt = Field (ar, offset);
+ elt = Field (ar, CAML_EPHE_DATA_OFFSET);
if(caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
if (elt == caml_ephe_none){
res = None_val;
CAMLprim value caml_ephe_get_key_copy (value ar, value n)
{
CAMLparam2 (ar, n);
- mlsize_t offset = Long_val (n) + 2;
+ mlsize_t offset = Long_val (n) + CAML_EPHE_FIRST_KEY;
CAMLlocal2 (res, elt);
value v; /* Caution: this is NOT a local root. */
CAMLassert (Is_in_heap (ar));
- if (offset < 1 || offset >= Wosize_val (ar)){
+ if (offset < CAML_EPHE_FIRST_KEY || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.get_copy");
}
CAMLprim value caml_ephe_get_data_copy (value ar)
{
CAMLparam1 (ar);
- mlsize_t offset = 1;
+ mlsize_t offset = CAML_EPHE_DATA_OFFSET;
CAMLlocal2 (res, elt);
value v; /* Caution: this is NOT a local root. */
CAMLassert (Is_in_heap (ar));
CAMLprim value caml_ephe_check_key (value ar, value n)
{
- mlsize_t offset = Long_val (n) + 2;
+ mlsize_t offset = Long_val (n) + CAML_EPHE_FIRST_KEY;
CAMLassert (Is_in_heap (ar));
- if (offset < 2 || offset >= Wosize_val (ar)){
+ if (offset < CAML_EPHE_FIRST_KEY || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.check");
}
return Val_bool (!is_ephe_key_none(ar, offset));
CAMLprim value caml_ephe_blit_key (value ars, value ofs,
value ard, value ofd, value len)
{
- mlsize_t offset_s = Long_val (ofs) + 2;
- mlsize_t offset_d = Long_val (ofd) + 2;
+ mlsize_t offset_s = Long_val (ofs) + CAML_EPHE_FIRST_KEY;
+ mlsize_t offset_d = Long_val (ofd) + CAML_EPHE_FIRST_KEY;
mlsize_t length = Long_val (len);
long i;
CAMLassert (Is_in_heap (ars));
CAMLassert (Is_in_heap (ard));
- if (offset_s < 1 || offset_s + length > Wosize_val (ars)){
+ if (offset_s < CAML_EPHE_FIRST_KEY || offset_s + length > Wosize_val (ars)){
caml_invalid_argument ("Weak.blit");
}
- if (offset_d < 1 || offset_d + length > Wosize_val (ard)){
+ if (offset_d < CAML_EPHE_FIRST_KEY || offset_d + length > Wosize_val (ard)){
caml_invalid_argument ("Weak.blit");
}
if (caml_gc_phase == Phase_clean){
/* Win32-specific stuff */
+/* FILE_INFO_BY_HANDLE_CLASS and FILE_NAME_INFO are only available from Windows
+ Vista onwards */
+#undef _WIN32_WINNT
+#define _WIN32_WINNT 0x0600
+
#define WIN32_LEAN_AND_MEAN
#include <wtypes.h>
#include <winbase.h>
#define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG)
#endif
-/* Very old Microsoft headers don't include intptr_t */
-#if defined(_MSC_VER) && !defined(_UINTPTR_T_DEFINED)
-typedef unsigned int uintptr_t;
-#define _UINTPTR_T_DEFINED
-#endif
-
unsigned short caml_win32_major = 0;
unsigned short caml_win32_minor = 0;
unsigned short caml_win32_build = 0;
static BOOL WINAPI ctrl_handler(DWORD event)
{
- int saved_mode;
-
/* Only ctrl-C and ctrl-Break are handled */
if (event != CTRL_C_EVENT && event != CTRL_BREAK_EVENT) return FALSE;
/* Default behavior is to exit, which we get by not handling the event */
static void expand_pattern(wchar_t * pat)
{
wchar_t * prefix, * p, * name;
- int handle;
+ intptr_t handle;
struct _wfinddata_t ffblk;
size_t i;
/* We need to stop at the first directory or drive boundary, because the
* _findata_t structure contains the filename, not the leading directory. */
for (i = wcslen(prefix); i > 0; i--) {
- char c = prefix[i - 1];
+ wchar_t c = prefix[i - 1];
if (c == L'\\' || c == L'/' || c == L':') { prefix[i] = 0; break; }
}
/* No separator was found, it's a filename pattern without a leading directory. */
{
size_t dirnamelen;
wchar_t * template;
-#if _MSC_VER <= 1200
- int h;
-#else
intptr_t h;
-#endif
struct _wfinddata_t fileinfo;
dirnamelen = wcslen(dirname);
wchar_t *caml_secure_getenv (wchar_t const *var)
{
/* Win32 doesn't have a notion of setuid bit, so getenv is safe. */
- return CAML_SYS_GETENV (var);
+ return _wgetenv(var);
+}
+
+/* caml_win32_getenv is used to implement Sys.getenv and Unix.getenv in such a
+ way that they get direct access to the Win32 environment rather than to the
+ copy that is cached by the C runtime system. The result of caml_win32_getenv
+ is dynamically allocated and must be explicitly deallocated.
+
+ In contrast, the OCaml runtime system still calls _wgetenv from the C runtime
+ system, via caml_secure_getenv. The result is statically allocated and needs
+ no deallocation. */
+CAMLexport wchar_t *caml_win32_getenv(wchar_t const *lpName)
+{
+ wchar_t * lpBuffer;
+ DWORD nSize = 256, res;
+
+ lpBuffer = caml_stat_alloc_noexc(nSize * sizeof(wchar_t));
+
+ if (lpBuffer == NULL)
+ return NULL;
+
+ res = GetEnvironmentVariable(lpName, lpBuffer, nSize);
+
+ if (res == 0) {
+ caml_stat_free(lpBuffer);
+ return NULL;
+ }
+
+ if (res < nSize)
+ return lpBuffer;
+
+ nSize = res;
+ lpBuffer = caml_stat_resize_noexc(lpBuffer, nSize * sizeof(wchar_t));
+
+ if (lpBuffer == NULL)
+ return NULL;
+
+ res = GetEnvironmentVariable(lpName, lpBuffer, nSize);
+
+ if (res == 0 || res >= nSize) {
+ caml_stat_free(lpBuffer);
+ return NULL;
+ }
+
+ return lpBuffer;
}
/* The rename() implementation in MSVC's CRT is based on MoveFile()
if (startup_codepage != 0)
SetConsoleOutputCP(startup_codepage);
}
+
+/* Detect if a named pipe corresponds to a Cygwin/MSYS pty: see
+ https://github.com/mirror/newlib-cygwin/blob/00e9bf2/winsup/cygwin/dtable.cc#L932
+*/
+typedef
+BOOL (WINAPI *tGetFileInformationByHandleEx)(HANDLE, FILE_INFO_BY_HANDLE_CLASS,
+ LPVOID, DWORD);
+
+static int caml_win32_is_cygwin_pty(HANDLE hFile)
+{
+ char buffer[1024];
+ FILE_NAME_INFO * nameinfo = (FILE_NAME_INFO *) buffer;
+ static tGetFileInformationByHandleEx pGetFileInformationByHandleEx = INVALID_HANDLE_VALUE;
+
+ if (pGetFileInformationByHandleEx == INVALID_HANDLE_VALUE)
+ pGetFileInformationByHandleEx =
+ (tGetFileInformationByHandleEx)GetProcAddress(GetModuleHandle(L"KERNEL32.DLL"),
+ "GetFileInformationByHandleEx");
+
+ if (pGetFileInformationByHandleEx == NULL)
+ return 0;
+
+ /* Get pipe name. GetFileInformationByHandleEx does not NULL-terminate the string, so reduce
+ the buffer size to allow for adding one. */
+ if (! pGetFileInformationByHandleEx(hFile, FileNameInfo, buffer, sizeof(buffer) - sizeof(WCHAR)))
+ return 0;
+
+ nameinfo->FileName[nameinfo->FileNameLength / sizeof(WCHAR)] = L'\0';
+
+ /* check if this could be a msys pty pipe ('msys-XXXX-ptyN-XX')
+ or a cygwin pty pipe ('cygwin-XXXX-ptyN-XX') */
+ if ((wcsstr(nameinfo->FileName, L"msys-") ||
+ wcsstr(nameinfo->FileName, L"cygwin-")) && wcsstr(nameinfo->FileName, L"-pty"))
+ return 1;
+
+ return 0;
+}
+
+CAMLexport int caml_win32_isatty(int fd)
+{
+ DWORD lpMode;
+ HANDLE hFile = (HANDLE)_get_osfhandle(fd);
+
+ if (hFile == INVALID_HANDLE_VALUE)
+ return 0;
+
+ switch (GetFileType(hFile)) {
+ case FILE_TYPE_CHAR:
+ /* Both console handles and the NUL device are FILE_TYPE_CHAR. The NUL
+ device returns FALSE for a GetConsoleMode call. _isatty incorrectly
+ only uses GetFileType (see GPR#1321). */
+ return GetConsoleMode(hFile, &lpMode);
+ case FILE_TYPE_PIPE:
+ /* Cygwin PTYs are implemented using named pipes */
+ return caml_win32_is_cygwin_pty(hFile);
+ default:
+ break;
+ }
+
+ return 0;
+}
+
+int caml_num_rows_fd(int fd)
+{
+ return -1;
+}
# Currently available:
# unix Unix system calls
# str Regular expressions and high-level string processing
-# num Arbitrary-precision rational arithmetic
# threads Lightweight concurrent processes
# systhreads Same as threads, requires POSIX threads
# graph Portable drawing primitives for X11
# dynlink Dynamic linking of bytecode
# bigarray Large, multidimensional numerical arrays
-OTHERLIBRARIES=unix str num threads graph dynlink bigarray
+OTHERLIBRARIES=unix str threads graph dynlink bigarray
### Link-time options to ocamlc or ocamlopt for linking with POSIX threads
# Needed for the "systhreads" package
UNIXLIB=win32unix
GRAPHLIB=win32graph
FLAMBDA=false
+WITH_FLAMBDA_INVARIANTS=false
WITH_SPACETIME=false
ENABLE_CALL_COUNTS=false
WITH_PROFINFO=false
DEFAULT_SAFE_STRING=true
WINDOWS_UNICODE=1
AFL_INSTRUMENT=false
+AWK=gawk
########## Configuration for the bytecode compiler
FLEXDLL_CHAIN=mingw
# FLEXLINK_FLAGS must be safe to insert in an OCaml string
# (see ocamlmklibconfig.ml in tools/Makefile)
-FLEXLINK_FLAGS=-chain $(FLEXDLL_CHAIN) -stack 16777216 -link -static-libgcc
+FLEXLINK_FLAGS=-chain $(FLEXDLL_CHAIN) -stack 16777216
FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS)
FLEXDIR:=$(shell $(FLEXLINK) -where 2>/dev/null)
ifeq ($(FLEXDIR),)
MKEXE_ANSI=$(FLEXLINK) -exe
### How to build a static library
-MKLIB=rm -f $(1); $(TOOLPREF)ar rc $(1) $(2); $(RANLIB) $(1)
+MKLIB=rm -f $(1) && $(TOOLPREF)ar rcs $(1) $(2)
#ml let mklib out files opts =
-#ml Printf.sprintf "rm -f %s && %sar rcs %s %s %s"
-#ml out toolpref opts out files;;
+#ml Printf.sprintf "%sar rcs %s %s %s"
+#ml toolpref opts out files;;
### Canonicalize the name of a system library
SYSLIB=-l$(1)
UNIXLIB=win32unix
GRAPHLIB=win32graph
FLAMBDA=false
+WITH_FLAMBDA_INVARIANTS=false
WITH_PROFINFO=false
WITH_SPACETIME=false
ENABLE_CALL_COUNTS=false
DEFAULT_SAFE_STRING=true
WINDOWS_UNICODE=1
AFL_INSTRUMENT=false
+AWK=gawk
########## Configuration for the bytecode compiler
MKEXE_ANSI=$(FLEXLINK) -exe
### How to build a static library
-MKLIB=rm -f $(1); $(TOOLPREF)ar rc $(1) $(2); $(RANLIB) $(1)
+MKLIB=rm -f $(1) && $(TOOLPREF)ar rcs $(1) $(2)
#ml let mklib out files opts =
-#ml Printf.sprintf "rm -f %s && %sar rcs %s %s %s"
-#ml out toolpref opts out files;;
+#ml Printf.sprintf "%sar rcs %s %s %s"
+#ml toolpref opts out files;;
### Canonicalize the name of a system library
SYSLIB=-l$(1)
UNIXLIB=win32unix
GRAPHLIB=win32graph
FLAMBDA=false
+WITH_FLAMBDA_INVARIANTS=false
WITH_PROFINFO=false
WITH_SPACETIME=false
ENABLE_CALL_COUNTS=false
DEFAULT_SAFE_STRING=true
WINDOWS_UNICODE=1
AFL_INSTRUMENT=false
+AWK=gawk
########## Configuration for the bytecode compiler
UNIXLIB=win32unix
GRAPHLIB=win32graph
FLAMBDA=false
+WITH_FLAMBDA_INVARIANTS=false
WITH_PROFINFO=false
WITH_SPACETIME=false
ENABLE_CALL_COUNTS=false
DEFAULT_SAFE_STRING=true
WINDOWS_UNICODE=1
AFL_INSTRUMENT=false
+AWK=gawk
########## Configuration for the bytecode compiler
#define OCAML_OS_TYPE "Win32"
-#ifdef __MINGW32__
+#if defined(__MINGW32__) || _MSC_VER >= 1600
#define HAS_STDINT_H
#endif
#undef BSD_SIGNALS
/* Define HAS_SIGSETMASK if you have sigsetmask(), as in BSD. */
-#define HAS_TERMCAP
-
-/* Define HAS_TERMCAP if you have the termcap functions to read the
- terminal database, e.g. tgetent(), tgetstr(), tgetnum(), tputs().
- Also add the required libraries (e.g. -lcurses -ltermcap) to $(CCLIBS)
- in ../Makefile.config */
-
#define SUPPORT_DYNAMIC_LINKING
/* Define SUPPORT_DYNAMIC_LINKING if dynamic loading of C stub code
asoption=''
asppoption=''
cclibs=''
-curseslibs=''
mathlib='-lm'
dllib=''
x11_include_dir=''
pthread_wanted=yes
dl_defs=''
verbose=false
-with_curses=yes
-debugruntime=false
-with_instrumented_runtime=false
+debugruntime=true
with_sharedlibs=true
partialld="ld -r"
with_debugger=ocamldebugger
with_cplugins=false
with_fpic=false
flat_float_array=true
+with_flambda_invariants=false
+
+# we distinguish '' (not set) from 'true' (explicitly set by the user)
+with_instrumented_runtime=''
# Try to turn internationalization off, can cause config.guess to malfunction!
unset LANG
-lib*)
cclibs="$2 $cclibs"; shift;;
-no-curses|--no-curses)
- with_curses=no;;
+ ;; # Ignored for backward compatibility
-no-shared-libs|--no-shared-libs)
with_sharedlibs=false;;
-x11include*|--x11include*)
-verbose|--verbose)
verbose=true;;
-with-debug-runtime|--with-debug-runtime)
- debugruntime=true;;
+ debugruntime=true;; # default
+ -no-debug-runtime|--no-debug-runtime)
+ debugruntime=false;;
-with-instrumented-runtime|--with-instrumented-runtime)
with_instrumented_runtime=true;;
+ -no-instrumented-runtime|--no-instrumented-runtime)
+ with_instrumented_runtime=false;;
-no-debugger|--no-debugger)
with_debugger="";;
-no-ocamldoc|--no-ocamldoc)
native_compiler=false;;
-flambda|--flambda)
flambda=true;;
+ -with-flambda-invariants|--with-flambda-invariants)
+ with_flambda_invariants=true;;
-with-cplugins|--with-cplugins)
with_cplugins=true;;
-no-cplugins|--no-cplugins)
exe=".exe"
ostype="Cygwin";;
*,*-*-mingw*)
- dllccompopt="-DCAML_DLL"
if $with_sharedlibs; then
case "$target" in
i686-*-*) flexlink_chain="mingw";;
powerpc-*-openbsd*) arch=power; model=ppc; system=bsd_elf;;
s390x*-*-linux*) arch=s390x; model=z10; system=elf;;
armv6*-*-linux-gnueabihf) arch=arm; model=armv6; system=linux_eabihf;;
- arm*-*-linux-gnueabihf) arch=arm; system=linux_eabihf;;
+ armv7*-*-linux-gnueabihf) arch=arm; model=armv7; system=linux_eabihf;;
+ armv8*-*-linux-gnueabihf) arch=arm; model=armv8; system=linux_eabihf;;
+ armv8*-*-linux-gnueabi) arch=arm; model=armv8; system=linux_eabi;;
armv7*-*-linux-gnueabi) arch=arm; model=armv7; system=linux_eabi;;
armv6t2*-*-linux-gnueabi) arch=arm; model=armv6t2; system=linux_eabi;;
armv6*-*-linux-gnueabi) arch=arm; model=armv6; system=linux_eabi;;
echo "#define HAS_ISSETUGID" >> s.h
fi
-# For the terminfo module
-
-if test "$with_curses" = "yes"; then
- for libs in "" "-lcurses" "-ltermcap" "-lcurses -ltermcap" "-lncurses"; do
- if sh ./hasgot $libs tgetent tgetstr tgetnum tputs; then
- inf "termcap functions found (with libraries '$libs')"
- echo "#define HAS_TERMCAP" >> s.h
- curseslibs="${libs}"
- break
- fi
- done
-fi
-
# For instrumented runtime
# (clock_gettime needs -lrt for glibc before 2.17)
-if $with_instrumented_runtime; then
- with_instrumented_runtime=false #enabled it only if found
+if test "$with_instrumented_runtime" != "false"; then
+ instrumented_runtime_support="nonsupported"
for libs in "" "-lrt"; do
if sh ./hasgot $libs clock_gettime; then
inf "clock_gettime functions found (with libraries '$libs')"
instrumented_runtime_libs="${libs}"
- with_instrumented_runtime=true;
+ instrumented_runtime_support="supported";
break
fi
done
- if ! $with_instrumented_runtime; then
- err "clock_gettime functions not found. " \
- "Instrumented runtime can't be built."
- fi
+ case "$with_instrumented_runtime,$instrumented_runtime_support" in
+ *,supported)
+ with_instrumented_runtime=true;;
+ true,nonsupported)
+ with_instrumented_runtime=false;
+ err "clock_gettime functions not found. " \
+ "Instrumented runtime can't be built.";;
+ ,nonsupported)
+ with_instrumented_runtime=false;
+ inf "clock_gettime functions not found. " \
+ "Instrumented runtime can't be built.";;
+ esac
fi
# Configuration for the libraries
\
/usr/lib/i386-linux-gnu \
/usr/lib/x86_64-linux-gnu \
+ \
+ /usr/lib/`echo $target | sed -e "s/-[^-]*//"` \
; \
do
if test -f $dir/libX11.a || \
if test $dir = /usr/lib; then
x11_link="-lX11"
else
- x11_libs="-L$dir"
case "$target" in
*-*-freebsd*|*-*-dragonfly*) x11_link="-L$dir -lX11";;
*-kfreebsd*-gnu) x11_link="-L$dir -lX11";;
done
fi
-if test "x11_include" != "not found"; then
+if test "$x11_include" != "not found"; then
if test "$x11_include" = "-I/usr/include"; then
x11_include=""
fi
config OCAMLC_CFLAGS "$common_cflags $sharedcccompopts"
config OCAMLC_CPPFLAGS "$common_cppflags"
config LDFLAGS "$ldflags"
-config BYTECCLIBS "$cclibs $dllib $curseslibs $pthread_link \
- $instrumented_runtime_libs"
+config BYTECCLIBS "$cclibs $dllib $pthread_link $instrumented_runtime_libs"
config RPATH "$rpath"
config EXE "$exe"
config EMPTY ""
#ml let syslib x = "-l"^x;;
### How to build a static library
-MKLIB=${TOOLPREF}ar rc \$(1) \$(2); ${TOOLPREF}ranlib \$(1)
+MKLIB=rm -f \$(1) && ${TOOLPREF}ar rc \$(1) \$(2) && ${TOOLPREF}ranlib \$(1)
#ml let mklib out files opts = (* "" *)
-#ml Printf.sprintf "${TOOLPREF}ar rc %s %s %s; ${TOOLPREF}ranlib %s"
+#ml Printf.sprintf "${TOOLPREF}ar rc %s %s %s && ${TOOLPREF}ranlib %s"
#ml out opts files out;;
EOF
config ARCH "$arch"
config DIFF "diff -q --strip-trailing-cr"
fi
config FLAMBDA "$flambda"
+config WITH_FLAMBDA_INVARIANTS "$with_flambda_invariants"
config FORCE_SAFE_STRING "$force_safe_string"
config DEFAULT_SAFE_STRING "$default_safe_string"
config WINDOWS_UNICODE "0"
config AFL_INSTRUMENT "$afl_instrument"
config MAX_TESTSUITE_DIR_RETRIES "$max_testsuite_dir_retries"
config FLAT_FLOAT_ARRAY "$flat_float_array"
+config AWK "awk"
rm -f tst hasgot.c
inf "Configuration for the bytecode compiler:"
inf " C compiler used........... $cc"
inf " options for compiling..... $common_cflags"
-inf " options for linking....... $ldflags $cclibs $dllib" \
- "$curseslibs $pthread_link"
+inf " options for linking....... $ldflags $cclibs $dllib $pthread_link"
if $shared_libraries_supported; then
inf " shared libraries are supported"
inf " options for compiling..... $sharedcccompopts $common_cflags"
fi
if $with_spacetime; then
inf " spacetime profiling....... yes"
- if test "$with_spacetime_call_counts" = "true"; then
+ if test "$enable_call_counts" = "true"; then
inf " ... with call counts.... yes"
else
inf " ... with call counts.... no"
fi
if test "$flambda" = "true"; then
inf " using flambda middle-end . yes"
+ if test "$with_flambda_invariants" = "true"; then
+ inf " ... with flambda invariants checks . yes"
+ else
+ inf " ... with flambda invariants checks . no"
+ fi
else
inf " using flambda middle-end . no"
fi
-breakpoints.cmo : symbols.cmi pos.cmi ../bytecomp/instruct.cmi exec.cmi \
- debugcom.cmi checkpoints.cmi breakpoints.cmi
-breakpoints.cmx : symbols.cmx pos.cmx ../bytecomp/instruct.cmx exec.cmx \
- debugcom.cmx checkpoints.cmx breakpoints.cmi
+breakpoints.cmo : symbols.cmi pos.cmi parameters.cmi \
+ ../bytecomp/instruct.cmi exec.cmi debugcom.cmi checkpoints.cmi \
+ breakpoints.cmi
+breakpoints.cmx : symbols.cmx pos.cmx parameters.cmx \
+ ../bytecomp/instruct.cmx exec.cmx debugcom.cmx checkpoints.cmx \
+ breakpoints.cmi
breakpoints.cmi : ../bytecomp/instruct.cmi
checkpoints.cmo : primitives.cmi int64ops.cmi debugcom.cmi checkpoints.cmi
checkpoints.cmx : primitives.cmx int64ops.cmx debugcom.cmx checkpoints.cmi
checkpoints.cmx history.cmi
history.cmi :
input_handling.cmo : $(UNIXDIR)/unix.cmi primitives.cmi \
- input_handling.cmi
+ parameters.cmi input_handling.cmi
input_handling.cmx : $(UNIXDIR)/unix.cmx primitives.cmx \
- input_handling.cmi
+ parameters.cmx input_handling.cmi
input_handling.cmi : primitives.cmi
int64ops.cmo : int64ops.cmi
int64ops.cmx : int64ops.cmi
lexer.cmx : parser.cmx lexer.cmi
lexer.cmi : parser.cmi
loadprinter.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi printval.cmi \
- ../typing/printtyp.cmi ../typing/path.cmi ../utils/misc.cmi \
- ../parsing/longident.cmi ../parsing/location.cmi ../typing/ident.cmi \
- ../typing/env.cmi ../typing/ctype.cmi ../utils/config.cmi \
- ../driver/compdynlink.cmi loadprinter.cmi
+ ../typing/printtyp.cmi ../typing/path.cmi parameters.cmi \
+ ../utils/misc.cmi ../parsing/longident.cmi ../parsing/location.cmi \
+ ../typing/ident.cmi ../typing/env.cmi ../typing/ctype.cmi \
+ ../utils/config.cmi ../driver/compdynlink.cmi loadprinter.cmi
loadprinter.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx printval.cmx \
- ../typing/printtyp.cmx ../typing/path.cmx ../utils/misc.cmx \
- ../parsing/longident.cmx ../parsing/location.cmx ../typing/ident.cmx \
- ../typing/env.cmx ../typing/ctype.cmx ../utils/config.cmx \
- ../driver/compdynlink.cmi loadprinter.cmi
+ ../typing/printtyp.cmx ../typing/path.cmx parameters.cmx \
+ ../utils/misc.cmx ../parsing/longident.cmx ../parsing/location.cmx \
+ ../typing/ident.cmx ../typing/env.cmx ../typing/ctype.cmx \
+ ../utils/config.cmx ../driver/compdynlink.cmi loadprinter.cmi
loadprinter.cmi : ../parsing/longident.cmi ../driver/compdynlink.cmi
main.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi time_travel.cmi \
show_information.cmi question.cmi program_management.cmi primitives.cmi \
- parameters.cmi ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \
- ../typing/env.cmi debugger_config.cmi ../utils/config.cmi \
- command_line.cmi ../typing/cmi_format.cmi ../utils/clflags.cmi \
- checkpoints.cmi
+ parameters.cmi ../utils/misc.cmi loadprinter.cmi input_handling.cmi \
+ frames.cmi exec.cmi ../typing/env.cmi debugger_config.cmi \
+ ../utils/config.cmi command_line.cmi ../typing/cmi_format.cmi \
+ ../utils/clflags.cmi checkpoints.cmi
main.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx time_travel.cmx \
show_information.cmx question.cmx program_management.cmx primitives.cmx \
- parameters.cmx ../utils/misc.cmx input_handling.cmx frames.cmx exec.cmx \
- ../typing/env.cmx debugger_config.cmx ../utils/config.cmx \
- command_line.cmx ../typing/cmi_format.cmx ../utils/clflags.cmx \
- checkpoints.cmx
+ parameters.cmx ../utils/misc.cmx loadprinter.cmx input_handling.cmx \
+ frames.cmx exec.cmx ../typing/env.cmx debugger_config.cmx \
+ ../utils/config.cmx command_line.cmx ../typing/cmi_format.cmx \
+ ../utils/clflags.cmx checkpoints.cmx
parameters.cmo : primitives.cmi ../typing/envaux.cmi debugger_config.cmi \
../utils/config.cmi parameters.cmi
parameters.cmx : primitives.cmx ../typing/envaux.cmx debugger_config.cmx \
#**************************************************************************
include ../config/Makefile
+include ../Makefile.common
+
UNIXDIR=../otherlibs/$(UNIXLIB)
CAMLRUN ?= ../boot/ocamlrun
CAMLYACC ?= ../boot/ocamlyacc
CAMLDEP=$(CAMLRUN) ../tools/ocamldep
DEPFLAGS=$(INCLUDES)
-INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
-
INCLUDES=\
-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../toplevel \
-I ../driver -I $(UNIXDIR)
../utils/identifiable.cmo ../utils/numbers.cmo \
../utils/arg_helper.cmo ../utils/clflags.cmo \
../utils/consistbl.cmo ../utils/warnings.cmo \
+ ../utils/build_path_prefix_map.cmo \
../utils/terminfo.cmo \
../parsing/location.cmo ../parsing/longident.cmo ../parsing/docstrings.cmo \
../parsing/syntaxerr.cmo \
$(CAMLC) $(LINKFLAGS) -o ocamldebug$(EXE) -linkall $(OTHEROBJS) $(OBJS)
install:
- cp ocamldebug$(EXE) "$(INSTALL_BINDIR)/ocamldebug$(EXE)"
+ $(INSTALL_PROG) ocamldebug$(EXE) "$(INSTALL_BINDIR)/ocamldebug$(EXE)"
clean::
rm -f ocamldebug$(EXE)
incr breakpoint_number;
insert_position event.ev_pos;
breakpoints := (!breakpoint_number, event) :: !breakpoints);
- printf "Breakpoint %d at %d: %s" !breakpoint_number event.ev_pos
- (Pos.get_desc event);
- print_newline ()
+ if !Parameters.breakpoint then begin
+ printf "Breakpoint %d at %d: %s" !breakpoint_number event.ev_pos
+ (Pos.get_desc event);
+ print_newline ()
+ end
(* Remove a breakpoint from lists. *)
let remove_breakpoint number =
(function () ->
breakpoints := List.remove_assoc number !breakpoints;
remove_position pos;
- printf "Removed breakpoint %d at %d: %s" number ev.ev_pos
- (Pos.get_desc ev);
- print_newline ()
+ if !Parameters.breakpoint then begin
+ printf "Removed breakpoint %d at %d: %s" number ev.ev_pos
+ (Pos.get_desc ev);
+ print_newline ()
+ end
)
with
Not_found ->
(* Resume reading user input. *)
let resume_user_input () =
if not (List.mem_assoc !user_channel.io_fd !active_files) then begin
- if !interactif then begin
+ if !interactif && !Parameters.prompt then begin
print_string !current_prompt;
flush Pervasives.stdout
end;
(* since 4.00, "topdirs.cmi" is not in the same directory as the standard
library, so we load it beforehand as it cannot be found in the search path. *)
-let () =
- let compiler_libs =
- Filename.concat Config.standard_library "compiler-libs" in
+let init () =
let topdirs =
- Filename.concat compiler_libs "topdirs.cmi" in
+ Filename.concat !Parameters.topdirs_path "topdirs.cmi" in
ignore (Env.read_signature "Topdirs" topdirs)
let match_printer_type desc typename =
let ty_arg = Ctype.newvar() in
Ctype.unify Env.empty
(Ctype.newconstr printer_type [ty_arg])
- (Ctype.instance Env.empty desc.val_type);
+ (Ctype.instance desc.val_type);
Ctype.end_def();
Ctype.generalize ty_arg;
ty_arg
open Format
+val init : unit -> unit
+
val loadfile : formatter -> string -> unit
val install_printer : formatter -> Longident.t -> unit
val remove_printer : Longident.t -> unit
Misc.expand_directory Config.standard_library d :: !default_load_path
let set_socket s =
socket_name := s
+let set_topdirs_path s =
+ topdirs_path := s
let set_checkpoints n =
checkpoint_max_count := n
let set_directory dir =
" Print version and exit";
"-vnum", Arg.Unit print_version_num,
" Print version number and exit";
+ "-no-version", Arg.Clear Parameters.version,
+ " Do not print version at startup";
+ "-no-prompt", Arg.Clear Parameters.prompt,
+ " Suppress all prompts";
+ "-no-time", Arg.Clear Parameters.time,
+ " Do not print times";
+ "-no-breakpoint-message", Arg.Clear Parameters.breakpoint,
+ " Do not print message at breakpoint setup and removal";
+ "-topdirs-path", Arg.String set_topdirs_path,
+ " Set path to the directory containing topdirs.cmi";
]
let function_placeholder () =
arguments := !arguments ^ " " ^ (Filename.quote Sys.argv.(j))
done
end;
- printf "\tOCaml Debugger version %s@.@." Config.version;
+ if !Parameters.version
+ then printf "\tOCaml Debugger version %s@.@." Config.version;
+ Loadprinter.init();
Config.load_path := !default_load_path;
Clflags.recursive_types := true; (* Allow recursive types. *)
toplevel_loop (); (* Toplevel. *)
let default_load_path =
ref [ Filename.current_dir_name; Config.standard_library ]
+let breakpoint = ref true
+let prompt = ref true
+let time = ref true
+let version = ref true
+
+let topdirs_path = ref (Filename.concat Config.standard_library "compiler-libs")
+
let add_path dir =
load_path := dir :: except dir !load_path;
Envaux.reset_cache()
val socket_name : string ref
val arguments : string ref
val default_load_path : string list ref
+val breakpoint : bool ref
+val prompt : bool ref
+val time : bool ref
+val version : bool ref
+val topdirs_path : string ref
val add_path : string -> unit
val add_path_for : string -> string -> unit
(* Display information about the current event. *)
let show_current_event ppf =
- fprintf ppf "Time: %Li" (current_time ());
- (match current_pc () with
- | Some pc ->
- fprintf ppf " - pc: %i" pc
- | _ -> ());
+ if !Parameters.time then begin
+ fprintf ppf "Time: %Li" (current_time ());
+ (match current_pc () with
+ | Some pc ->
+ fprintf ppf " - pc: %i" pc
+ | _ -> ());
+ end;
update_current_event ();
reset_frame ();
match current_report () with
| None ->
- fprintf ppf "@.Beginning of program.@.";
+ if !Parameters.time then fprintf ppf "@.";
+ fprintf ppf "Beginning of program.@.";
show_no_point ()
| Some {rep_type = (Event | Breakpoint); rep_program_pointer = pc} ->
let ev = get_current_event () in
- fprintf ppf " - module %s@." ev.ev_module;
+ if !Parameters.time then fprintf ppf " - module %s@." ev.ev_module;
(match breakpoints_at_pc pc with
| [] ->
()
(List.sort compare breakpoints));
show_point ev true
| Some {rep_type = Exited} ->
- fprintf ppf "@.Program exit.@.";
+ if !Parameters.time then fprintf ppf "@.";
+ fprintf ppf "Program exit.@.";
show_no_point ()
| Some {rep_type = Uncaught_exc} ->
+ if !Parameters.time then fprintf ppf "@.";
fprintf ppf
- "@.Program end.@.\
+ "Program end.@.\
@[Uncaught exception:@ %a@]@."
Printval.print_exception (Debugcom.Remote_value.accu ());
show_no_point ()
| Some {rep_type = Trap_barrier} ->
(* Trap_barrier not visible outside *)
(* of module `time_travel'. *)
+ if !Parameters.time then fprintf ppf "@.";
Misc.fatal_error "Show_information.show_current_event"
(* Display short information about one frame. *)
else bsearch (pivot + 1) hi
end
in
- bsearch 0 (Array.length ev - 1)
+ if Array.length ev = 0 then
+ raise Not_found
+ else
+ bsearch 0 (Array.length ev - 1)
(* Return first event after the given position. *)
(* Raise [Not_found] if module is unknown or no event is found. *)
type readenv_position =
Before_args | Before_compile of filename | Before_link
-(* Syntax of OCAMLPARAM: (name=VALUE,)* _ (,name=VALUE)*
- where VALUE should not contain ',' *)
+(* Syntax of OCAMLPARAM: SEP?(name=VALUE SEP)* _ (SEP name=VALUE)*
+ where VALUE should not contain SEP, and SEP is ',' if unspecified,
+ or ':', '|', ';', ' ' or ',' *)
exception SyntaxError of string
let parse_args s =
- let args = String.split_on_char ',' s in
+ let args =
+ let len = String.length s in
+ if len = 0 then []
+ else
+ (* allow first char to specify an alternative separator in ":|; ," *)
+ match s.[0] with
+ | ( ':' | '|' | ';' | ' ' | ',' ) as c ->
+ List.tl (String.split_on_char c s)
+ | _ -> String.split_on_char ',' s
+ in
let rec iter is_after args before after =
match args with
[] ->
if not is_after then
raise (SyntaxError "no '_' separator found")
else
- (List.rev before, List.rev after)
+ (List.rev before, List.rev after)
+ | "" :: tail -> iter is_after tail before after
| "_" :: _ when is_after -> raise (SyntaxError "too many '_' separators")
| "_" :: tail -> iter true tail before after
| arg :: tail ->
set "flambda-verbose" [ dump_flambda_verbose ] v
| "flambda-invariants" ->
set "flambda-invariants" [ flambda_invariant_checks ] v
+ | "linscan" ->
+ set "linscan" [ use_linscan ] v
(* color output *)
| "color" ->
ccobjs := Misc.rev_split_words v @ !ccobjs
end
- | "ccopts" ->
+ | "ccopt"
+ | "ccopts"
+ ->
begin
match position with
| Before_link | Before_compile _ ->
if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
let sg = tsg.sig_type in
if !Clflags.print_types then
- Printtyp.wrap_printing_env initial_env (fun () ->
+ Printtyp.wrap_printing_env ~error:false initial_env (fun () ->
fprintf std_formatter "%a@."
Printtyp.signature (Typemod.simplify_signature sg));
ignore (Includemod.signatures initial_env sg sg);
(* Note: do not do init_path() in initial_env, this breaks
toplevel initialization (PR#1775) *)
-let open_implicit_module m env =
- let open Asttypes in
- let lid = {loc = Location.in_file "command line";
- txt = Longident.parse m } in
- snd (Typemod.type_open_ Override env lid.loc lid)
-
let initial_env () =
Ident.reinit();
- let initial =
- if Config.safe_string then Env.initial_safe_string
- else if !Clflags.unsafe_string then Env.initial_unsafe_string
- else Env.initial_safe_string
- in
- let env =
- if !Clflags.nopervasives then initial else
- open_implicit_module "Pervasives" initial
+ let initially_opened_module =
+ if !Clflags.nopervasives then
+ None
+ else
+ Some "Stdlib"
in
- List.fold_left (fun env m ->
- open_implicit_module m env
- ) env (!implicit_modules @ List.rev !Clflags.open_modules)
-
+ Typemod.initial_env
+ ~loc:(Location.in_file "command line")
+ ~safe_string:(Config.safe_string || not !Clflags.unsafe_string)
+ ~initially_opened_module
+ ~open_implicit_modules:(!implicit_modules @ List.rev !Clflags.open_modules)
let read_color_env ppf =
try
let _where = print_standard_library
let _verbose = set verbose
let _nopervasives = set nopervasives
+ let _dno_unique_ids = unset unique_ids
+ let _dunique_ids = set unique_ids
let _dsource = set dump_source
let _dparsetree = set dump_parsetree
let _dtypedtree = set dump_typedtree
let mk_thread f =
"-thread", Arg.Unit f,
- " Generate code that supports the system threads library"
+ " (deprecated) same as -I +threads"
;;
let mk_dtimings f =
"-drawlambda", Arg.Unit f, " (undocumented)"
;;
+let mk_dno_unique_ids f =
+ "-dno-unique-ids", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dunique_ids f =
+ "-dunique-ids", Arg.Unit f, " (undocumented)"
+;;
+
let mk_dsource f =
"-dsource", Arg.Unit f, " (undocumented)"
;;
"-drawflambda", Arg.Unit f, " Print Flambda terms after closure conversion"
;;
+let mk_dflambda_invariants f =
+ "-dflambda-invariants", Arg.Unit f, " Check Flambda invariants \
+ around each pass"
+;;
+
let mk_dflambda_no_invariants f =
"-dflambda-no-invariants", Arg.Unit f, " Do not Check Flambda invariants \
around each pass"
val _warn_error : string -> unit
val _warn_help : unit -> unit
+ val _dno_unique_ids : unit -> unit
+ val _dunique_ids : unit -> unit
val _dsource : unit -> unit
val _dparsetree : unit -> unit
val _dtypedtree : unit -> unit
val _clambda_checks : unit -> unit
val _dflambda : unit -> unit
val _drawflambda : unit -> unit
+ val _dflambda_invariants : unit -> unit
val _dflambda_no_invariants : unit -> unit
val _dflambda_let : int -> unit
val _dflambda_verbose : unit -> unit
mk_nopervasives F._nopervasives;
mk_use_prims F._use_prims;
+ mk_dno_unique_ids F._dno_unique_ids;
+ mk_dunique_ids F._dunique_ids;
mk_dsource F._dsource;
mk_dparsetree F._dparsetree;
mk_dtypedtree F._dtypedtree;
mk_warn_help F._warn_help;
mk__ F.anonymous;
+ mk_dno_unique_ids F._dno_unique_ids;
+ mk_dunique_ids F._dunique_ids;
mk_dsource F._dsource;
mk_dparsetree F._dparsetree;
mk_dtypedtree F._dtypedtree;
mk__ F.anonymous;
mk_nopervasives F._nopervasives;
+ mk_dno_unique_ids F._dno_unique_ids;
+ mk_dunique_ids F._dunique_ids;
mk_dsource F._dsource;
mk_dparsetree F._dparsetree;
mk_dtypedtree F._dtypedtree;
mk_dclambda F._dclambda;
mk_dflambda F._dflambda;
mk_drawflambda F._drawflambda;
+ mk_dflambda_invariants F._dflambda_invariants;
mk_dflambda_no_invariants F._dflambda_no_invariants;
mk_dflambda_let F._dflambda_let;
mk_dflambda_verbose F._dflambda_verbose;
val _warn_error : string -> unit
val _warn_help : unit -> unit
+ val _dno_unique_ids : unit -> unit
+ val _dunique_ids : unit -> unit
val _dsource : unit -> unit
val _dparsetree : unit -> unit
val _dtypedtree : unit -> unit
val _clambda_checks : unit -> unit
val _dflambda : unit -> unit
val _drawflambda : unit -> unit
+ val _dflambda_invariants : unit -> unit
val _dflambda_no_invariants : unit -> unit
val _dflambda_let : int -> unit
val _dflambda_verbose : unit -> unit
if !worklist <> [] then begin
Format.fprintf Format.err_formatter
- "@[Warning: cycle in dependencies. End of list is not sorted.@]@.";
+ "@[%t: cycle in dependencies. End of list is not sorted.@]@."
+ Location.print_error_prefix;
let sorted_deps =
let li = ref [] in
Hashtbl.iter (fun _ file_deps -> li := file_deps :: !li) h;
) !deps;
Format.fprintf Format.err_formatter "@]@.";
Printf.printf "%s " file) sorted_deps;
+ error_occurred := true
end;
Printf.printf "\n%!";
()
if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
let sg = tsg.sig_type in
if !Clflags.print_types then
- Printtyp.wrap_printing_env initial_env (fun () ->
+ Printtyp.wrap_printing_env ~error:false initial_env (fun () ->
fprintf std_formatter "%a@."
Printtyp.signature (Typemod.simplify_signature sg));
ignore (Includemod.signatures initial_env sg sg);
let _where () = print_standard_library ()
let _nopervasives = set nopervasives
+ let _dno_unique_ids = clear unique_ids
+ let _dunique_ids = set unique_ids
let _dsource = set dump_source
let _dparsetree = set dump_parsetree
let _dtypedtree = set dump_typedtree
let _dflambda_verbose () =
set dump_flambda ();
set dump_flambda_verbose ()
+ let _dflambda_invariants = set flambda_invariant_checks
let _dflambda_no_invariants = clear flambda_invariant_checks
let _dcmm = set dump_cmm
let _dsel = set dump_selection
#**************************************************************************
include ../config/Makefile
+include ../Makefile.common
# Files to install
FILES= caml-font.el caml-hilit.el caml.el camldebug.el \
simple-install:
@echo "Installing in $(EMACSDIR)..."
if test -d $(EMACSDIR); then : ; else mkdir -p $(EMACSDIR); fi
- cp $(FILES) $(EMACSDIR)
+ $(INSTALL_DATA) $(FILES) $(EMACSDIR)
if [ -z "$(NOCOMPILE)" ]; then \
cd $(EMACSDIR); $(EMACS) --batch --eval '$(COMPILECMD)'; \
fi
chmod a+x ocamltags
install-ocamltags: ocamltags
- cp ocamltags $(SCRIPTDIR)/ocamltags
+ $(INSTALL_DATA) ocamltags $(SCRIPTDIR)/ocamltags
# This is for testing purposes
compile-only:
(setq font-lock-variable-name-face 'DarkGoldenRod)
(setq font-lock-type-face 'DarkOliveGreen)
(setq font-lock-reference-face 'CadetBlue)))
- ; extra faces for documention
+ ; extra faces for documentation
(make-face 'Stop)
(set-face-foreground 'Stop "White")
(set-face-background 'Stop "Red")
"when" "while" "with")
'words))
. font-lock-constant-face)
- ("\\<raise\\|failwith\\|invalid_arg\\>"
+ ("\\<\\(raise\\|failwith\\|invalid_arg\\)\\>"
. font-lock-comment-face)
;labels (and open)
("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]"
;; This is a preliminary version.
;;
;; Possible improvements?
-;; - dump some databaes: Info, Lib, ...
+;; - dump some databases: Info, Lib, ...
;; - accept a search path for local libraries instead of current dir
;; (then distinguish between different modules lying in different
;; directories)
;;
;; Abstract over
;; - the viewing method and the database, so that the documentation for
-;; and identifier could be search in
-;; * info / html / man / mli's sources
+;; an identifier could be
+;; * searched in info / html / man / mli's sources
;; * viewed in Emacs or using an external previewer.
;;
;; Take all identifiers (labels, Constructors, exceptions, etc.)
(defvar ocaml-lib-path 'lazy
"Path list for ocaml lib sources (mli files).
-`lazy' means ask ocaml to find it for your at first use.")
+`lazy' means ask ocaml to find it for you at first use.")
(defun ocaml-lib-path ()
"Compute if necessary and return the path for ocaml libs."
(if (listp ocaml-lib-path) nil
ocaml-visible-modules)
(defun ocaml-open-module (arg)
- "*Make module of name ARG visible whe ARG is a string.
+ "*Make module of name ARG visible when ARG is a string.
When call interactively, make completion over known modules."
(interactive "P")
(if (not (stringp arg))
(defun caml-complete (arg)
"Does completion for OCaml identifiers qualified.
-It attemps to recognize an qualified identifier Module . entry
+It attemps to recognize a qualified identifier Module . entry
around point using function \\[ocaml-qualified-identifier].
If Module is defined, it does completion for identifier in Module.
(defun caml-help (arg)
"Find documentation for OCaml qualified identifiers.
-It attemps to recognize an qualified identifier of the form
+It attempts to recognize a qualified identifier of the form
``Module . entry'' around point using function `ocaml-qualified-identifier'.
If Module is undetermined it is temptatively guessed from the identifier name
-and according to visible modules. If this is still unsucessful, the user is
+and according to visible modules. If this is still unsuccessful, the user is
then prompted for a Module name.
-The documentation for Module is first seach in the info manual if available,
+The documentation for Module is first searched in the info manual, if available,
then in the ``module.mli'' source file. The entry is then searched in the
documentation.
from the file content.
Prefix arg 4 prompts for Module and identifier instead of guessing values
-from the possition of point in the current buffer."
+from the position of point in the current buffer."
(interactive "p")
(delete-overlay ocaml-help-ovl)
(let ((module) (entry) (module-entry))
(defvar ocaml-links nil
"Local links in the current of last info node or interface file.
-The car of the list is a key that indentifies the module to prevent
+The car of the list is a key that identifies the module to prevent
recompilation when next help command is relative to the same module.
-The cdr is a list of elments, each of which is an string and a pair of
+The cdr is a list of elements, each of which is a string and a pair of
buffer positions."
)
(make-variable-buffer-local 'ocaml-links)
(error (message "End of buffer!")))))
(setq speed (* speed speed)))))
;; main action, when the motion is inside the window
- ;; or on orginal button down event
+ ;; or on original button down event
((or (caml-mouse-movement-p event)
(equal original-event event))
(setq cnum (caml-event-point-end event))
;; However, it could also be a key stroke before mouse release.
;; Emacs does not allow to test whether mouse is up or down.
;; Not sure it is robust to loop for mouse release after an error
- ;; occured, as is done for exploration.
+ ;; occurred, as is done for exploration.
;; So far, we just ignore next event. (Next line also be uncommenting.)
(if event (caml-read-event)))))
(make-variable-buffer-local 'caml-apply-extra-indent)
(defvar caml-begin-indent 2
- "*How many spaces to indent from a begin keyword in caml mode.")
+ "*How many spaces to indent from a \"begin\" keyword in caml mode.")
(make-variable-buffer-local 'caml-begin-indent)
(defvar caml-class-indent 2
- "*How many spaces to indent from a class keyword in caml mode.")
+ "*How many spaces to indent from a \"class\" keyword in caml mode.")
(make-variable-buffer-local 'caml-class-indent)
(defvar caml-exception-indent 2
- "*How many spaces to indent from a exception keyword in caml mode.")
+ "*How many spaces to indent from an \"exception\" keyword in caml mode.")
(make-variable-buffer-local 'caml-exception-indent)
(defvar caml-for-indent 2
- "*How many spaces to indent from a for keyword in caml mode.")
+ "*How many spaces to indent from a \"for\" keyword in caml mode.")
(make-variable-buffer-local 'caml-for-indent)
(defvar caml-fun-indent 2
- "*How many spaces to indent from a fun keyword in caml mode.")
+ "*How many spaces to indent from a \"fun\" keyword in caml mode.")
(make-variable-buffer-local 'caml-fun-indent)
(defvar caml-function-indent 4
- "*How many spaces to indent from a function keyword in caml mode.")
+ "*How many spaces to indent from a \"function\" keyword in caml mode.")
(make-variable-buffer-local 'caml-function-indent)
(defvar caml-if-indent 2
- "*How many spaces to indent from a if keyword in caml mode.")
+ "*How many spaces to indent from an \"if\" keyword in caml mode.")
(make-variable-buffer-local 'caml-if-indent)
(defvar caml-if-else-indent 0
- "*How many spaces to indent from an if .. else line in caml mode.")
+ "*How many spaces to indent from an \"if .. else\" line in caml mode.")
(make-variable-buffer-local 'caml-if-else-indent)
(defvar caml-inherit-indent 2
- "*How many spaces to indent from a inherit keyword in caml mode.")
+ "*How many spaces to indent from an \"inherit\" keyword in caml mode.")
(make-variable-buffer-local 'caml-inherit-indent)
(defvar caml-initializer-indent 2
- "*How many spaces to indent from a initializer keyword in caml mode.")
+ "*How many spaces to indent from an \"initializer\" keyword in caml mode.")
(make-variable-buffer-local 'caml-initializer-indent)
(defvar caml-include-indent 2
- "*How many spaces to indent from a include keyword in caml mode.")
+ "*How many spaces to indent from an \"include\" keyword in caml mode.")
(make-variable-buffer-local 'caml-include-indent)
(defvar caml-let-indent 2
- "*How many spaces to indent from a let keyword in caml mode.")
+ "*How many spaces to indent from a \"let\" keyword in caml mode.")
(make-variable-buffer-local 'caml-let-indent)
(defvar caml-let-in-indent 0
- "*How many spaces to indent from a let .. in keyword in caml mode.")
+ "*How many spaces to indent from a \"let .. in\" keyword in caml mode.")
(make-variable-buffer-local 'caml-let-in-indent)
(defvar caml-match-indent 2
- "*How many spaces to indent from a match keyword in caml mode.")
+ "*How many spaces to indent from a \"match\" keyword in caml mode.")
(make-variable-buffer-local 'caml-match-indent)
(defvar caml-method-indent 2
- "*How many spaces to indent from a method keyword in caml mode.")
+ "*How many spaces to indent from a \"method\" keyword in caml mode.")
(make-variable-buffer-local 'caml-method-indent)
(defvar caml-module-indent 2
- "*How many spaces to indent from a module keyword in caml mode.")
+ "*How many spaces to indent from a \"module\" keyword in caml mode.")
(make-variable-buffer-local 'caml-module-indent)
(defvar caml-object-indent 2
- "*How many spaces to indent from a object keyword in caml mode.")
+ "*How many spaces to indent from an \"object\" keyword in caml mode.")
(make-variable-buffer-local 'caml-object-indent)
(defvar caml-of-indent 2
- "*How many spaces to indent from a of keyword in caml mode.")
+ "*How many spaces to indent from an \"of\" keyword in caml mode.")
(make-variable-buffer-local 'caml-of-indent)
(defvar caml-parser-indent 4
- "*How many spaces to indent from a parser keyword in caml mode.")
+ "*How many spaces to indent from a \"parser\" keyword in caml mode.")
(make-variable-buffer-local 'caml-parser-indent)
(defvar caml-sig-indent 2
- "*How many spaces to indent from a sig keyword in caml mode.")
+ "*How many spaces to indent from a \"sig\" keyword in caml mode.")
(make-variable-buffer-local 'caml-sig-indent)
(defvar caml-struct-indent 2
- "*How many spaces to indent from a struct keyword in caml mode.")
+ "*How many spaces to indent from a \"struct\" keyword in caml mode.")
(make-variable-buffer-local 'caml-struct-indent)
(defvar caml-try-indent 2
- "*How many spaces to indent from a try keyword in caml mode.")
+ "*How many spaces to indent from a \"try\" keyword in caml mode.")
(make-variable-buffer-local 'caml-try-indent)
(defvar caml-type-indent 4
- "*How many spaces to indent from a type keyword in caml mode.")
+ "*How many spaces to indent from a \"type\" keyword in caml mode.")
(make-variable-buffer-local 'caml-type-indent)
(defvar caml-val-indent 2
- "*How many spaces to indent from a val keyword in caml mode.")
+ "*How many spaces to indent from a \"val\" keyword in caml mode.")
(make-variable-buffer-local 'caml-val-indent)
(defvar caml-while-indent 2
- "*How many spaces to indent from a while keyword in caml mode.")
+ "*How many spaces to indent from a \"while\" keyword in caml mode.")
(make-variable-buffer-local 'caml-while-indent)
(defvar caml-::-indent 2
- "*How many spaces to indent from a :: operator in caml mode.")
+ "*How many spaces to indent from a \"::\" operator in caml mode.")
(make-variable-buffer-local 'caml-::-indent)
(defvar caml-@-indent 2
- "*How many spaces to indent from a @ operator in caml mode.")
+ "*How many spaces to indent from a \"@\" operator in caml mode.")
(make-variable-buffer-local 'caml-@-indent)
(defvar caml-:=-indent 2
- "*How many spaces to indent from a := operator in caml mode.")
+ "*How many spaces to indent from a \":=\" operator in caml mode.")
(make-variable-buffer-local 'caml-:=-indent)
(defvar caml-<--indent 2
- "*How many spaces to indent from a <- operator in caml mode.")
+ "*How many spaces to indent from a \"<-\" operator in caml mode.")
(make-variable-buffer-local 'caml-<--indent)
(defvar caml-->-indent 2
- "*How many spaces to indent from a -> operator in caml mode.")
+ "*How many spaces to indent from a \"->\" operator in caml mode.")
(make-variable-buffer-local 'caml-->-indent)
(defvar caml-lb-indent 2
- "*How many spaces to indent from a \[ operator in caml mode.")
+ "*How many spaces to indent from a \"\[\" operator in caml mode.")
(make-variable-buffer-local 'caml-lb-indent)
(defvar caml-lc-indent 2
- "*How many spaces to indent from a \{ operator in caml mode.")
+ "*How many spaces to indent from a \"\{\" operator in caml mode.")
(make-variable-buffer-local 'caml-lc-indent)
(defvar caml-lp-indent 1
- "*How many spaces to indent from a \( operator in caml mode.")
+ "*How many spaces to indent from a \"\(\" operator in caml mode.")
(make-variable-buffer-local 'caml-lp-indent)
(defvar caml-and-extra-indent nil
- "*Extra indent for caml lines starting with the and keyword.
+ "*Extra indent for caml lines starting with the \"and\" keyword.
Usually negative. nil is align on master.")
(make-variable-buffer-local 'caml-and-extra-indent)
(defvar caml-do-extra-indent nil
- "*Extra indent for caml lines starting with the do keyword.
+ "*Extra indent for caml lines starting with the \"do\" keyword.
Usually negative. nil is align on master.")
(make-variable-buffer-local 'caml-do-extra-indent)
(defvar caml-done-extra-indent nil
- "*Extra indent for caml lines starting with the done keyword.
+ "*Extra indent for caml lines starting with the \"done\" keyword.
Usually negative. nil is align on master.")
(make-variable-buffer-local 'caml-done-extra-indent)
(defvar caml-else-extra-indent nil
- "*Extra indent for caml lines starting with the else keyword.
+ "*Extra indent for caml lines starting with the \"else\" keyword.
Usually negative. nil is align on master.")
(make-variable-buffer-local 'caml-else-extra-indent)
(defvar caml-end-extra-indent nil
- "*Extra indent for caml lines starting with the end keyword.
+ "*Extra indent for caml lines starting with the \"end\" keyword.
Usually negative. nil is align on master.")
(make-variable-buffer-local 'caml-end-extra-indent)
(defvar caml-in-extra-indent nil
- "*Extra indent for caml lines starting with the in keyword.
+ "*Extra indent for caml lines starting with the \"in\" keyword.
Usually negative. nil is align on master.")
(make-variable-buffer-local 'caml-in-extra-indent)
(defvar caml-then-extra-indent nil
- "*Extra indent for caml lines starting with the then keyword.
+ "*Extra indent for caml lines starting with the \"then\" keyword.
Usually negative. nil is align on master.")
(make-variable-buffer-local 'caml-then-extra-indent)
(defvar caml-to-extra-indent -1
- "*Extra indent for caml lines starting with the to keyword.
+ "*Extra indent for caml lines starting with the \"to\" keyword.
Usually negative. nil is align on master.")
(make-variable-buffer-local 'caml-to-extra-indent)
(defvar caml-with-extra-indent nil
- "*Extra indent for caml lines starting with the with keyword.
+ "*Extra indent for caml lines starting with the \"with\" keyword.
Usually negative. nil is align on master.")
(make-variable-buffer-local 'caml-with-extra-indent)
(make-variable-buffer-local 'caml-|-extra-indent)
(defvar caml-rb-extra-indent -2
- "*Extra indent for caml lines statring with ].
+ "*Extra indent for caml lines starting with ].
Usually negative. nil is align on master.")
(defvar caml-rc-extra-indent -2
(defvar caml-electric-indent t
"*Non-nil means electrically indent lines starting with |, ] or }.
-Many people find eletric keys irritating, so you can disable them if
+Many people find electric keys irritating, so you can disable them if
you are one.")
(defvar caml-electric-close-vector t
"*Non-nil means electrically insert a | before a vector-closing ].
-Many people find eletric keys irritating, so you can disable them if
+Many people find electric keys irritating, so you can disable them if
you are one. You should probably have this on, though, if you also
have caml-electric-indent on, which see.")
(defun caml-eval-phrase (arg &optional min max)
"Send the phrase containing the point to the CAML process.
With prefix-arg send as many phrases as its numeric value,
-If an error occurs during evalutaion, stop at this phrase and
-repport the error.
+If an error occurs during evaluation, stop at this phrase and
+report the error.
Return nil if noerror and position of error if any.
(defun caml-in-comment-p ()
"Returns non-nil if point is inside a caml comment.
-Returns nil for the parenthesis openning a comment."
+Returns nil for the parenthesis opening a comment."
;;we look for comments differently than literals. there are two
;;reasons for this. first, caml has nested comments and it is not so
;;clear that parse-partial-sexp supports them; second, if proper
"Look back for a caml keyword or operator matching KWOP-REGEXP.
Second optional argument MIN-POS bounds the search.
-Ignore occurences inside literals. If found, return a list of two
+Ignore occurrences inside literals. If found, return a list of two
values: the actual text of the keyword or operator, and a boolean
indicating whether the keyword was one we looked for explicitly
{non-nil}, or on the other hand one of the block-terminating
"Explore type annotations by mouse dragging." t)
(autoload 'caml-help "caml-help"
- "Show documentation for qualilifed OCaml identifier." t)
+ "Show documentation for qualified OCaml identifier." t)
(autoload 'caml-complete "caml-help"
"Does completion for documented qualified OCaml identifier." t)
(autoload 'ocaml-open-module "caml-help"
the last line referred to in the camldebug buffer.
\\[camldebug-step], \\[camldebug-back] and \\[camldebug-next], in the camldebug
-window,call camldebug to step, backstep or next and then update the other window
+window, call camldebug to step, backstep or next and then update the other window
with the current file and position.
If you are in a source file, you may select a point to break
;; User modifiable variables
-;; Whether you want the output buffer to be diplayed when you send a phrase
+;; Whether you want the output buffer to be displayed when you send a phrase
(defvar caml-display-when-eval t
"*If true, display the inferior caml buffer when evaluating expressions.")
(goto-char loc)))
-;;; orgininal inf-caml.el ended here
+;;; original inf-caml.el ended here
;; as eval-phrase, but ignores errors.
beg))
(defvar caml-previous-output nil
- "tells the beginning of output in the shell-output buffer, so that the
-output can be retreived later, asynchronously.")
+ "Tells the beginning of output in the shell-output buffer, so that the
+output can be retrieved later, asynchronously.")
-;; enriched version of eval-phrase, to repport errors.
+;; enriched version of eval-phrase, to report errors.
(defun inferior-caml-eval-phrase (arg &optional min max)
"Send the phrase containing the point to the CAML process.
With prefix-arg send as many phrases as its numeric value,
-If an error occurs during evalutaion, stop at this phrase and
-repport the error.
+If an error occurs during evaluation, stop at this phrase and
+report the error.
Return nil if noerror and position of error if any.
open Lexgen
open Common
-let output_auto_defs oc has_refill =
- output_string oc
- "let __ocaml_lex_init_lexbuf lexbuf mem_size =\
-\n let pos = lexbuf.Lexing.lex_curr_pos in\
-\n lexbuf.Lexing.lex_mem <- Array.make mem_size (-1) ;\
-\n lexbuf.Lexing.lex_start_pos <- pos ;\
-\n lexbuf.Lexing.lex_last_pos <- pos ;\
-\n lexbuf.Lexing.lex_last_action <- -1\
-\n\n\
-" ;
-
- if has_refill then
- output_string oc
- "let rec __ocaml_lex_next_char lexbuf state k =\
-\n if lexbuf.Lexing.lex_curr_pos >= lexbuf.Lexing.lex_buffer_len then begin\
-\n if lexbuf.Lexing.lex_eof_reached then\
-\n state lexbuf k 256\
-\n else begin\
-\n __ocaml_lex_refill (fun lexbuf ->\
-\n lexbuf.Lexing.refill_buff lexbuf ;\
-\n __ocaml_lex_next_char lexbuf state k)\
-\n lexbuf\
-\n end\
-\n end else begin\
-\n let i = lexbuf.Lexing.lex_curr_pos in\
-\n let c = Bytes.get lexbuf.Lexing.lex_buffer i in\
-\n lexbuf.Lexing.lex_curr_pos <- i+1 ;\
-\n state lexbuf k (Char.code c)\
-\n end\
-\n\n"
- else
- output_string oc
- "let rec __ocaml_lex_next_char lexbuf =\
-\n if lexbuf.Lexing.lex_curr_pos >= lexbuf.Lexing.lex_buffer_len then begin\
-\n if lexbuf.Lexing.lex_eof_reached then\
-\n 256\
-\n else begin\
-\n lexbuf.Lexing.refill_buff lexbuf ;\
-\n __ocaml_lex_next_char lexbuf\
-\n end\
-\n end else begin\
-\n let i = lexbuf.Lexing.lex_curr_pos in\
-\n let c = Bytes.get lexbuf.Lexing.lex_buffer i in\
-\n lexbuf.Lexing.lex_curr_pos <- i+1 ;\
-\n Char.code c\
-\n end\
-\n\n"
-
-
-let output_pats oc pats = List.iter (fun p -> fprintf oc "|%d" p) pats
-
-let output_action oc has_refill mems r =
- output_memory_actions " " oc mems ;
+type ctx = {
+ oc: out_channel;
+ has_refill: bool;
+ goto_state: (ctx -> string -> int -> unit);
+ last_action: int option;
+}
+
+let pr ctx = fprintf ctx.oc
+
+let output_auto_defs ctx =
+ if ctx.has_refill then begin
+ pr ctx "\n";
+ pr ctx "let rec __ocaml_lex_refill_buf lexbuf _buf _len _curr _last _last_action state k =\n";
+ pr ctx " if lexbuf.Lexing.lex_eof_reached then\n";
+ pr ctx " state lexbuf _last_action _buf _len _curr _last k 256\n";
+ pr ctx " else begin\n";
+ pr ctx " lexbuf.Lexing.lex_curr_pos <- _curr;\n";
+ pr ctx " lexbuf.Lexing.lex_last_pos <- _last;\n";
+ pr ctx " __ocaml_lex_refill\n";
+ pr ctx " (fun lexbuf ->\n";
+ pr ctx " let _curr = lexbuf.Lexing.lex_curr_pos in\n";
+ pr ctx " let _last = lexbuf.Lexing.lex_last_pos in\n";
+ pr ctx " let _len = lexbuf.Lexing.lex_buffer_len in\n";
+ pr ctx " let _buf = lexbuf.Lexing.lex_buffer in\n";
+ pr ctx " if _curr < _len then\n";
+ pr ctx " state lexbuf _last_action _buf _len (_curr + 1) _last k\n";
+ pr ctx " (Char.code (Bytes.unsafe_get _buf _curr))\n";
+ pr ctx " else\n";
+ pr ctx " __ocaml_lex_refill_buf lexbuf _buf _len _curr _last _last_action\n";
+ pr ctx " state k\n";
+ pr ctx " )\n";
+ pr ctx " lexbuf\n";
+ pr ctx " end\n";
+ pr ctx "\n";
+ end else begin
+ pr ctx "\n";
+ pr ctx "let rec __ocaml_lex_refill_buf lexbuf _buf _len _curr _last =\n";
+ pr ctx " if lexbuf.Lexing.lex_eof_reached then\n";
+ pr ctx " 256, _buf, _len, _curr, _last\n";
+ pr ctx " else begin\n";
+ pr ctx " lexbuf.Lexing.lex_curr_pos <- _curr;\n";
+ pr ctx " lexbuf.Lexing.lex_last_pos <- _last;\n";
+ pr ctx " lexbuf.Lexing.refill_buff lexbuf;\n";
+ pr ctx " let _curr = lexbuf.Lexing.lex_curr_pos in\n";
+ pr ctx " let _last = lexbuf.Lexing.lex_last_pos in\n";
+ pr ctx " let _len = lexbuf.Lexing.lex_buffer_len in\n";
+ pr ctx " let _buf = lexbuf.Lexing.lex_buffer in\n";
+ pr ctx " if _curr < _len then\n";
+ pr ctx " Char.code (Bytes.unsafe_get _buf _curr), _buf, _len, (_curr + 1), _last\n";
+ pr ctx " else\n";
+ pr ctx " __ocaml_lex_refill_buf lexbuf _buf _len _curr _last\n";
+ pr ctx " end\n";
+ pr ctx "\n";
+ end
+
+let output_memory_actions pref oc = function
+ | [] -> ()
+ | mvs ->
+ output_string oc pref;
+ output_string oc "(* " ;
+ fprintf oc "L=%d " (List.length mvs) ;
+ List.iter
+ (fun mv -> match mv with
+ | Copy (tgt, src) ->
+ fprintf oc "[%d] <- [%d] ;" tgt src
+ | Set tgt ->
+ fprintf oc "[%d] <- p ; " tgt)
+ mvs ;
+ output_string oc " *)\n" ;
+ List.iter
+ (fun mv -> match mv with
+ | Copy (tgt, src) ->
+ fprintf oc
+ "%s%a <- %a ;\n"
+ pref output_mem_access tgt output_mem_access src
+ | Set tgt ->
+ fprintf oc "%s%a <- _curr;\n"
+ pref output_mem_access tgt)
+ mvs
+
+let output_pats ctx = function
+ | [x] -> pr ctx "| %d" x
+ | pats -> List.iter (fun p -> pr ctx "|%d" p) pats
+
+let last_action ctx =
+ match ctx.last_action with
+ | None -> "_last_action"
+ | Some i -> Printf.sprintf "%i (* = last_action *)" i
+
+let output_action ctx pref mems r =
+ output_memory_actions pref ctx.oc mems;
match r with
| Backtrack ->
- fprintf oc
- " lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_last_pos ;\n" ;
- if has_refill then
- fprintf oc " k lexbuf lexbuf.Lexing.lex_last_action\n"
- else
- fprintf oc " lexbuf.Lexing.lex_last_action\n"
+ pr ctx "%slet _curr = _last in\n\
+ %slexbuf.Lexing.lex_curr_pos <- _curr;\n\
+ %slexbuf.Lexing.lex_last_pos <- _last;\n"
+ pref pref pref;
+ if ctx.has_refill then
+ pr ctx "%sk lexbuf %s\n" pref (last_action ctx)
+ else
+ pr ctx "%s%s\n" pref (last_action ctx)
| Goto n ->
- fprintf oc " __ocaml_lex_state%d lexbuf%s\n" n
- (if has_refill then " k" else "")
+ ctx.goto_state ctx pref n
-let output_pat oc i =
+let output_pat ctx i =
if i >= 256 then
- fprintf oc "|eof"
+ pr ctx "|eof"
else
- fprintf oc "|'%s'" (Char.escaped (Char.chr i))
-
-let output_clause oc has_refill pats mems r =
- fprintf oc "(* " ;
- List.iter (output_pat oc) pats ;
- fprintf oc " *)\n" ;
- fprintf oc " %a ->\n" output_pats pats ;
- output_action oc has_refill mems r
+ pr ctx "|'%s'" (Char.escaped (Char.chr i))
-let output_default_clause oc has_refill mems r =
- fprintf oc " | _ ->\n" ; output_action oc has_refill mems r
+let output_clause ctx pref pats mems r =
+ pr ctx "%s(* " pref;
+ List.iter (output_pat ctx) pats;
+ pr ctx " *)\n%s" pref;
+ output_pats ctx pats;
+ pr ctx " ->\n";
+ output_action ctx (" "^pref) mems r
+let output_default_clause ctx pref mems r =
+ pr ctx "%s| _ ->\n" pref;
+ output_action ctx (" "^pref) mems r
-let output_moves oc has_refill moves =
+let output_moves ctx pref moves =
let t = Hashtbl.create 17 in
let add_move i (m,mems) =
let mems,r = try Hashtbl.find t m with Not_found -> mems,[] in
Hashtbl.iter
(fun m (mems,pats) ->
if m <> !most_frequent then
- output_clause oc has_refill (List.rev pats) mems m)
+ output_clause ctx pref (List.rev pats) mems m)
t ;
- output_default_clause oc has_refill !most_mems !most_frequent
+ output_default_clause ctx pref !most_mems !most_frequent
-let output_tag_actions pref oc mvs =
- output_string oc "(*" ;
+let output_tag_actions pref ctx mvs =
+ pr ctx "%s(*" pref;
List.iter
(fun i -> match i with
- | SetTag (t,m) -> fprintf oc " t%d <- [%d] ;" t m
- | EraseTag t -> fprintf oc " t%d <- -1 ;" t)
+ | SetTag (t,m) -> pr ctx " t%d <- [%d] ;" t m
+ | EraseTag t -> pr ctx " t%d <- -1 ;" t)
mvs ;
- output_string oc " *)\n" ;
+ pr ctx " *)\n" ;
List.iter
(fun i -> match i with
| SetTag (t,m) ->
- fprintf oc "%s%a <- %a ;\n"
+ pr ctx "%s%a <- %a ;\n"
pref output_mem_access t output_mem_access m
| EraseTag t ->
- fprintf oc "%s%a <- -1 ;\n"
+ pr ctx "%s%a <- -1 ;\n"
pref output_mem_access t)
mvs
-let output_trans pref oc has_refill i trans =
- let entry = sprintf "__ocaml_lex_state%d" i in
- fprintf oc "%s %s lexbuf %s= " pref entry
- (if has_refill then "k " else "");
- match trans with
+let output_trans_body pref ctx = function
| Perform (n,mvs) ->
- output_tag_actions " " oc mvs ;
- fprintf oc " %s%d\n"
- (if has_refill then "k lexbuf " else "")
- n
+ output_tag_actions pref ctx mvs ;
+ pr ctx "%slexbuf.Lexing.lex_curr_pos <- _curr;\n" pref;
+ pr ctx "%slexbuf.Lexing.lex_last_pos <- _last;\n" pref;
+ pr ctx "%s%s%d\n" pref (if ctx.has_refill then "k lexbuf " else "") n
| Shift (trans, move) ->
- begin match trans with
- | Remember (n,mvs) ->
- output_tag_actions " " oc mvs ;
- fprintf oc
- " lexbuf.Lexing.lex_last_pos <- lexbuf.Lexing.lex_curr_pos ;\n" ;
- fprintf oc " lexbuf.Lexing.lex_last_action <- %d ;\n" n;
- | No_remember -> ()
- end;
- if has_refill then
- let next = entry ^ "_next" in
- fprintf oc " __ocaml_lex_next_char lexbuf %s k\n" next;
- fprintf oc "and %s lexbuf k = function " next
- else
- output_string oc "match __ocaml_lex_next_char lexbuf with\n";
- output_moves oc has_refill move
-
-let output_automata oc has_refill auto =
- output_auto_defs oc has_refill;
+ let ctx =
+ match trans with
+ | Remember (n,mvs) ->
+ output_tag_actions pref ctx mvs ;
+ pr ctx "%slet _last = _curr in\n" pref;
+ begin match ctx.last_action with
+ | Some i when i = n ->
+ pr ctx "%s(* let _last_action = %d in*)\n" pref n;
+ ctx
+ | _ ->
+ pr ctx "%slet _last_action = %d in\n" pref n;
+ {ctx with last_action = Some n}
+ end
+ | No_remember ->
+ ctx
+ in
+ if ctx.has_refill then begin
+ (* TODO: bind this 'state' function at toplevel instead *)
+ pr ctx
+ "%slet state lexbuf _last_action _buf _len _curr _last k = function\n"
+ pref;
+ output_moves ctx pref move;
+ pr ctx "%sin\n\
+ %sif _curr >= _len then\n\
+ %s __ocaml_lex_refill_buf lexbuf _buf _len _curr _last _last_action state k\n\
+ %selse\n\
+ %s state lexbuf _last_action _buf _len (_curr + 1) _last k\n\
+ %s (Char.code (Bytes.unsafe_get _buf _curr))\n"
+ pref pref pref pref pref pref
+ end
+ else begin
+ pr ctx "%slet next_char, _buf, _len, _curr, _last =\n\
+ %s if _curr >= _len then\n\
+ %s __ocaml_lex_refill_buf lexbuf _buf _len _curr _last\n\
+ %s else\n\
+ %s Char.code (Bytes.unsafe_get _buf _curr),\n\
+ %s _buf, _len, (_curr + 1), _last\n\
+ %sin\n\
+ %sbegin match next_char with\n"
+ pref pref pref pref pref pref pref pref;
+ output_moves ctx (pref ^ " ") move;
+ pr ctx "%send\n" pref
+ end
+
+let output_automata ctx auto inline =
+ output_auto_defs ctx;
let n = Array.length auto in
- output_trans "let rec" oc has_refill 0 auto.(0) ;
- for i = 1 to n-1 do
- output_trans "\nand" oc has_refill i auto.(i)
- done ;
- output_char oc '\n'
+ let first = ref true in
+ for i = 0 to n-1 do
+ if not inline.(i) then begin
+ pr ctx
+ "%s __ocaml_lex_state%d lexbuf _last_action _buf _len _curr _last %s=\n"
+ (if !first then "let rec" else "\nand")
+ i
+ (if ctx.has_refill then "k " else "");
+ output_trans_body " " ctx auto.(i);
+ first := false;
+ end
+ done;
+ pr ctx "\n\n"
(* Output the entries *)
-let output_entry ic oc has_refill tr e =
- let init_num, init_moves = e.auto_initial_state in
- fprintf oc "%s %alexbuf =\n __ocaml_lex_init_lexbuf lexbuf %d; %a"
- e.auto_name output_args e.auto_args
- e.auto_mem_size
- (output_memory_actions " ") init_moves;
- fprintf oc
- (if has_refill
- then "\n __ocaml_lex_state%d lexbuf (fun lexbuf __ocaml_lex_result ->"
- else "\n let __ocaml_lex_result = __ocaml_lex_state%d lexbuf in")
- init_num;
- output_string oc "\
-\n lexbuf.Lexing.lex_start_p <- lexbuf.Lexing.lex_curr_p;\
-\n lexbuf.Lexing.lex_curr_p <- {lexbuf.Lexing.lex_curr_p with\
-\n Lexing.pos_cnum = lexbuf.Lexing.lex_abs_pos+lexbuf.Lexing.lex_curr_pos};\
-\n match __ocaml_lex_result with\n";
+let output_init ctx pref e init_moves =
+ if e.auto_mem_size > 0 then
+ pr ctx "%slexbuf.Lexing.lex_mem <- Array.make %d (-1);\n"
+ pref e.auto_mem_size;
+ pr ctx "%slet _curr = lexbuf.Lexing.lex_curr_pos in\n" pref;
+ pr ctx "%slet _last = _curr in\n" pref;
+ pr ctx "%slet _len = lexbuf.Lexing.lex_buffer_len in\n" pref;
+ pr ctx "%slet _buf = lexbuf.Lexing.lex_buffer in\n" pref;
+ pr ctx "%slet _last_action = -1 in\n" pref;
+ pr ctx "%slexbuf.Lexing.lex_start_pos <- _curr;\n" pref;
+ output_memory_actions pref ctx.oc init_moves
+
+let output_rules ic ctx pref tr e =
+ pr ctx "%sbegin\n" pref;
+ pr ctx "%s let _curr_p = lexbuf.Lexing.lex_curr_p in\n" pref;
+ pr ctx "%s if _curr_p != Lexing.dummy_pos then begin\n" pref;
+ pr ctx "%s lexbuf.Lexing.lex_start_p <- _curr_p;\n" pref;
+ pr ctx "%s lexbuf.Lexing.lex_curr_p <-\n" pref;
+ pr ctx "%s {_curr_p with Lexing.pos_cnum =\n" pref;
+ pr ctx "%s lexbuf.Lexing.lex_abs_pos+lexbuf.Lexing.lex_curr_pos}\n" pref;
+ pr ctx "%s end\n" pref;
+ pr ctx "%send;\n" pref;
+ pr ctx "%smatch __ocaml_lex_result with\n" pref;
List.iter
(fun (num, env, loc) ->
- fprintf oc " | ";
- fprintf oc "%d ->\n" num;
- output_env ic oc tr env ;
- copy_chunk ic oc tr loc true;
- fprintf oc "\n")
+ pr ctx "%s| %d ->\n" pref num;
+ output_env ic ctx.oc tr env;
+ copy_chunk ic ctx.oc tr loc true;
+ pr ctx "\n")
e.auto_actions;
- fprintf oc " | _ -> raise (Failure \"lexing: empty token\")\n";
- if has_refill then
- output_string oc " )\n\n"
- else
- output_string oc "\n\n"
+ pr ctx "%s| _ -> raise (Failure \"lexing: empty token\")\n" pref
+
+let output_entry ic ctx tr e =
+ let init_num, init_moves = e.auto_initial_state in
+ pr ctx "%s %alexbuf =\n" e.auto_name output_args e.auto_args;
+
+ if ctx.has_refill then begin
+ pr ctx " let k lexbuf __ocaml_lex_result =\n";
+ output_rules ic ctx " " tr e;
+ pr ctx " in\n";
+ output_init ctx " " e init_moves;
+ ctx.goto_state ctx " " init_num
+ end else begin
+ pr ctx " let __ocaml_lex_result =\n";
+ output_init ctx " " e init_moves;
+ ctx.goto_state ctx " " init_num;
+ pr ctx " in\n";
+ output_rules ic ctx " " tr e
+ end;
+ pr ctx "\n\n"
+
+
+(* Determine which states to inline *)
+let choose_inlining entry_points transitions =
+ let counters = Array.make (Array.length transitions) 0 in
+ let count i = counters.(i) <- counters.(i) + 1 in
+ List.iter (fun e -> count (fst e.auto_initial_state)) entry_points;
+ Array.iter
+ (function
+ | Shift (_, a) ->
+ let tbl = Hashtbl.create 8 in
+ Array.iter
+ (function
+ | (Goto i, _) when not (Hashtbl.mem tbl i) ->
+ Hashtbl.add tbl i (); count i
+ | _ -> ()
+ )
+ a
+ | Perform _ -> ()
+ )
+ transitions;
+ Array.mapi
+ (fun i -> function
+ | Perform _ -> true
+ | Shift _ -> counters.(i) = 1
+ )
+ transitions
+
+let goto_state inline transitions ctx pref n =
+ if inline.(n) then
+ output_trans_body pref ctx transitions.(n)
+ else
+ pr ctx "%s__ocaml_lex_state%d lexbuf %s _buf _len _curr _last%s\n"
+ pref n
+ (last_action ctx)
+ (if ctx.has_refill then " k" else "")
(* Main output function *)
copy_chunk ic oc tr header false;
let has_refill = output_refill_handler ic oc tr rh in
- output_automata oc has_refill transitions;
+ let inline = choose_inlining entry_points transitions in
+ let ctx =
+ {
+ has_refill;
+ oc;
+ goto_state = goto_state inline transitions;
+ last_action = None;
+ }
+ in
+ output_automata ctx transitions inline;
begin match entry_points with
[] -> ()
| entry1 :: entries ->
output_string oc "let rec ";
- output_entry ic oc has_refill tr entry1;
+ output_entry ic ctx tr entry1;
List.iter
(fun e -> output_string oc "and ";
- output_entry ic oc has_refill tr e)
+ output_entry ic ctx tr e)
entries;
output_string oc ";;\n\n";
end;
.B \-safe\-string
Enforce the separation between types
.BR string \ and\ bytes ,
-thereby making strings read-only. This will become the default in
-a future version of OCaml.
+thereby making strings read-only. This is the default.
.TP
.B \-short\-paths
When a type is visible under several module-paths, use the shortest
.B \-unsafe\-string
Identify the types
.BR string \ and\ bytes ,
-thereby making strings writable. For reasons of backward compatibility,
-this is the default setting for the moment, but this will change in a future
-version of OCaml.
+thereby making strings writable.
+This is intended for compatibility with old source code and should not
+be used with new software.
.TP
.B \-version
Print version string and exit.
.B \-safe\-string
Enforce the separation between types
.BR string \ and\ bytes ,
-thereby making strings read-only. This will become the default in
-a future version of OCaml.
+thereby making strings read-only. This is the default.
.TP
.B \-short\-paths
When a type is visible under several module-paths, use the shortest
.B \-strict\-sequence
Force the left-hand part of each sequence to have type unit.
.TP
-.B \-thread
-Compile or link multithreaded programs, in combination with the
-system "threads" library described in
-.IR The\ OCaml\ user's\ manual .
-.TP
.B \-unboxed\-types
When a type is unboxable (i.e. a record with a single argument or a
concrete datatype with a single constructor of one argument) it will
.B \-unsafe\-string
Identify the types
.BR string \ and\ bytes ,
-thereby making strings writable. For reasons of backward compatibility,
-this is the default setting for the moment, but this will change in a future
-version of OCaml.
+thereby making strings writable.
+This is intended for compatibility with old source code and should not
+be used with new software.
.TP
.BI \-use\-runtime \ runtime\-name
Generate a bytecode executable file that can be executed on the custom
option ensures that this module will
always be linked if it is put in a library and this library is linked.
.TP
+.B \-linscan
+Use linear scan register allocation. Compiling with this allocator is faster
+than with the usual graph coloring allocator, sometimes quite drastically so for
+long functions and modules. On the other hand, the generated code can be a bit
+slower.
+.TP
.B \-no-alias-deps
Do not record dependencies for module aliases.
.TP
.B \-safe\-string
Enforce the separation between types
.BR string \ and\ bytes ,
-thereby making strings read-only. This will become the default in
-a future version of OCaml.
+thereby making strings read-only. This is the default.
.TP
.B \-shared
Build a plugin (usually .cmxs) that can be dynamically loaded with
.B \-strict\-sequence
The left-hand part of a sequence must have type unit.
.TP
-.B \-thread
-Compile or link multithreaded programs, in combination with the
-system threads library described in
-.IR "The OCaml user's manual" .
-.TP
.B \-unboxed\-types
When a type is unboxable (i.e. a record with a single argument or a
concrete datatype with a single constructor of one argument) it will
.B \-unsafe\-string
Identify the types
.BR string \ and\ bytes ,
-thereby making strings writable. For reasons of backward compatibility,
-this is the default setting for the moment, but this will change in a future
-version of OCaml.
+thereby making strings writable.
+This is intended for compatibility with old source code and should not
+be used with new software.
.TP
.B \-v
Print the version number of the compiler and the location of the
--- /dev/null
+The present documentation is copyright Institut National de Recherche
+en Informatique et en Automatique (INRIA).
+
+The OCaml documentation and user's manual may be reproduced and
+distributed in whole or in part, subject to the following conditions:
+
+- The copyright notice above and this permission notice must be
+ preserved complete on all complete or partial copies.
+
+- Any translation or derivative work of the OCaml documentation and
+ user's manual must be approved by the authors in writing before
+ distribution.
+
+- If you distribute the OCaml documentation and user's manual in part,
+ instructions for obtaining the complete version of this manual must
+ be included, and a means for obtaining a complete version provided.
+
+- Small portions may be reproduced as illustrations for reviews or
+ quotes in other works without this permission notice if proper
+ citation is given.
--- /dev/null
+all: tools
+ cd manual; ${MAKE} all
+ ${MAKE} tests
+# cd fpcl; ${MAKE} all
+
+clean:
+ cd manual; ${MAKE} clean
+ cd tools; ${MAKE} clean
+# cd fpcl; ${MAKE} clean
+
+release:
+ cd manual; ${MAKE} release
+# cd fpcl; ${MAKE} release
+
+.PHONY: tools
+tools:
+ cd tools; ${MAKE} clean; ${MAKE} all
+
+# The pregen-etex target generates the latex files from the .etex
+# files to ensure that this phase of the manual build process, which
+# may execute OCaml fragments and expect certain outputs, is correct
+pregen-etex: tools
+ cd manual; $(MAKE) etex-files
+
+# pregen builds both .etex files and the documentation of the standard library
+pregen: tools
+ cd manual; $(MAKE) files
+
+# test the consistency of the manual and the compiler source
+.PHONY:tests
+tests:
+ ${MAKE} -C tests all
--- /dev/null
+OCAML DOCUMENTATION
+===================
+
+Prerequisites
+-------------
+
+- Any prerequisites required to build OCaml from sources.
+
+- The Unix editor 'ed', no longer installed by default on some systems.
+
+- A LaTeX installation.
+
+- The HeVeA LaTeX-to-HTML convertor (available in OPAM):
+ <http://hevea.inria.fr/>
+
+Note that you must make sure `hevea.sty` is installed into TeX properly. Your
+package manager may not do this for you. Run `kpsewhich hevea.sty` to check.
+
+
+Building
+--------
+
+0. Install the OCaml distribution.
+
+1. Run `make` in the manual.
+
+NB: If you already set `LD_LIBRARY_PATH` (OS X: `DYLD_LIBRARY_PATH`)
+ in your environment don't forget to add
+ `otherlibs/unix:otherlibs/str` to it in an absolute way.
+
+Outputs
+-------
+
+In the manual:
+
+- The HTML Manual is in directory `htmlman`. The main file is `index.html`.
+
+- The plain text manual is in directory `textman` as file `manual.txt`.
+
+- The Info manual is in directory `infoman`.
+
+- The DVI manual is in directory `texstuff` as file `manual.dvi`.
+
+- The PDF manual is in directory `texstuff` as file `pdfmanual.pdf`.
+
+Source files
+------------
+The manual is written in an extended dialect of latex and is split in many
+source files. During the build process, the sources files are converted into
+classical latex file using the tools available in `tools`. These files are
+then converted to the different output formats using either latex or hevea.
+
+Each part of the manual corresponds to a specific directory, and each distinct
+chapters (or sometimes sections) are mapped to a distinct `.etex` file:
+
+- Part I, Introduction to OCaml: `tutorials`
+ - The core language: `coreexamples.etex`
+ - The module system: `moduleexamples.etex`
+ - Objects in OCaml: `objectexamples.etex`
+ - Labels and variants: `lablexamples.etex`
+ - Advanced examples with classes and modules: `advexamples.etex`
+
+- Part II, The OCaml language: `refman`
+ This part is separated in two very distinct chapters; the
+ `OCaml language` chapter and the `Language extensions` chapter.
+
+ - The OCaml language: `refman.etex`
+ This chapter consists in a technical description of the OCaml language.
+ Each section of this chapter is mapped to a separated latex file:
+ - `lex.etex`, `values.etex`, `names.etex`, `types.etex`, `const.etex`,
+ `patterns.etex`, `expr.etex`, `typedecl.etex`, `classes.etex`,
+ `modtypes.etex`, `compunit.etex`
+
+ - Language extensions: `exten.etex`
+ This chapter contains a description of all recent features of the OCaml
+ language.
+
+- Part III, The OCaml tools: 'cmds'
+ - Batch compilation (ocamlc): `comp.etex`
+ - The toplevel system (ocaml): `top.etex`
+ - The runtime system (ocamlrun): `runtime.etex`
+ - Native-code compilation (ocamlopt): `native.etex`
+ - Lexer and parser generators (ocamllex, ocamlyacc): `lexyacc.etex`
+ - Dependency generator (ocamldep): `ocamldep.etex`
+ - The browser/editor (ocamlbrowser): `browser.etex`
+ - The documentation generator (ocamldoc): `ocamldoc.etex`
+ - The debugger (ocamldebug): `debugger.etex`
+ - Profiling (ocamlprof): `profil.etex`
+ - The ocamlbuild compilation manager: `ocamlbuild.etex`
+ - Interfacing C with OCaml: `intf-c.etex`
+ - Optimisation with Flambda: `flambda.etex`
+ - Memory profiling with Spacetime: `spacetime.etex`
+ - Fuzzing with afl-fuzz: `afl-fuzz.etex`
+
+Note that ocamlc,ocamlopt and the toplevel options overlap a lot.
+Consequently, these options are described together in the file
+`unified-options.etex` and then included from `comp.etex`, `native.etex`,
+and `top.etex`. If you need to update this list of options, the top comment
+of `unified-options.etex` contains the relevant information.
+
+- Part IV, The OCaml library: 'libref'
+ This parts contains an brief presentation of all libraries bundled with the
+ compilers and the api documentation generated for these libraries.
+ - The core library: `core.etex`
+ - The standard library: `stdlib.etex`
+ - The compiler front-end: `compilerlibs.etex`
+ - The unix library: Unix system calls: `libunix.etex`
+ - The legacy num library: this library has been removed from the core
+ distribution, see `libnum.etex`
+ - The str library: regular expressions and string processing: `libstr.etex`
+ - The threads library: `libthreads.etex`
+ - The graphics library: `libgraph.etex`
+ - The dynlink library: dynamic loading and linking of object files:
+ `libdynlink.etex`
+ - The bigarray library: `libbigarray.etex`
+
+Latex extensions
+----------------
+
+### Caml environments
+
+The tool `tool/caml-tex2` is used to generate the latex code for the examples
+in the introduction and language extension parts of the manual. It implements
+two pseudo-environments: `caml_example` and `caml_eval`.
+
+The pseudo-environment `caml_example` evaluates its contents using an ocaml
+interpreter and then translates both the input code and the interpreter output
+to latex code, e.g.
+```latex
+\begin{caml_example}{toplevel}
+let f x = x;;
+\end{caml_example}
+```
+Note that the toplevel output can be suppressed by using a `*` suffix:
+```latex
+\begin{caml_example*}{verbatim}
+let f x = x
+\end{caml_example*}
+```
+
+The `{verbatim}` or `{toplevel}` argument of the environment corresponds
+to the the mode of the example, two modes are available `toplevel` and
+`verbatim`.
+The `toplevel` mode mimics the appearance and behavior of the toplevel.
+In particular, toplevel examples must end with a double semi-colon `;;`,
+otherwise an error would be raised.
+The `verbatim` does not require a final `;;` and is intended to be
+a lighter mode for code examples.
+
+By default, `caml_tex2` raises an error and stops if the output of one
+the `caml_example` environment contains an unexpected error or warning.
+If such an error or warning is, in fact, expected, it is necessary to
+indicate the expected output status to `caml_tex2` by adding either
+an option to the `caml_example` environment:
+```latex
+\begin{caml_example}{toplevel}[error]
+1 + 2. ;;
+\end{caml_example}
+ or for warning
+\begin{caml_example}[warning=8]
+let f None = None;;
+\end{caml_example}
+```
+or an annotation to the concerned phrase:
+
+```latex
+\begin{caml_example}{toplevel}
+1 + 2. [@@expect error] ;;
+let f None = None [@@expect warning 8];;
+3 + 4 [@@expect ok];;
+\end{caml_example}
+```
+
+It is also possible to elide a code fragment by annotating it with
+an `[@ellipsis]` attribute
+
+```latex
+\begin{caml_example}{toplevel}
+let f: type a. a list -> int = List.length[@ellipsis] ;;
+\end{caml_example}
+```
+For module components, it might be easier to hide them by using
+`[@@@ellipsis.start]` and `[@@@ellipsis.stop]`:
+```latex
+\begin{caml_example*}{verbatim}
+module M = struct
+ [@@@ellipsis.start]
+ type t = T
+ let x = 0
+ [@@@ellipsis.stop]
+ end
+\end{caml_example*}
+```
+
+Another possibility to avoid displaying distracting code is to use
+the `caml_eval` environment. This environment is a companion environment
+to `caml_example` and can be used to evaluate OCaml expressions in the
+toplevel without printing anything:
+```latex
+\begin{caml_eval}
+let pi = 4. *. atan 1.;;
+\end{caml_eval}
+\begin{caml_example}{toplevel}
+let f x = x +. pi;;
+\end{caml_example}
+```
+Beware that the detection code for these pseudo-environments is quite brittle
+and the environments must start and end at the beginning of the line.
+
+### Quoting
+
+The tool `tools/texquote2` provides support for verbatim-like quotes using
+`\"` delimiters. More precisely, outside of caml environments and verbatim
+environments, `texquote2` translates double quotes `"text"` to
+`\machine{escaped_text}`.
+
+### BNF grammar notation
+
+The tool `tools/transf` provides support for BNF grammar notations and special
+quotes for non-terminal. When transf is used, the environment `syntax` can
+be used to describe grammars using BNF notation:
+```latex
+\begin{syntax}
+expr:
+ value-path
+ | constant
+ | '(' expr ')'
+ | 'begin' expr 'end'
+ | '(' expr ':' typexpr ')'
+ | expr {{',' expr}}
+ | constr expr
+ | "`"tag-name expr
+ | expr '::' expr
+ | '[' expr { ';' expr } [';'] ']'
+ | '[|' expr { ';' expr } [';'] '|]'
+ | '{' field [':' typexpr] '=' expr%
+ { ';' field [':' typexpr] '=' expr } [';'] '}'
+\end{syntax}
+```
+Notice that terminal symbols are quoted using `'` delimiters.
+Moreover, outside of the syntax environment, `@`-quotes can be used
+to introduce fragment of grammar: `@'(' module-expr ')'@`. As a consequence,
+when this extension is used `@` characters must be escaped as `\@`.
+This extension is used mainly in the language reference part of the manual.
+and a more complete description of the notation used is available in the
+first subsection of `refman/refman.etex`.
+
+Consistency tests
+-----------------
+
+The `tests` folder contains consistency tests that checks that the manual
+and the rest of the compiler sources stay synced.
--- /dev/null
+allfiles.tex
+biblio.tex
+foreword.tex
+version.tex
+warnings.etex
+warnings.tex
+foreword.htex
+manual.html
--- /dev/null
+# $Id$
+
+FILES=allfiles.tex biblio.tex foreword.tex version.tex warnings-help.etex
+TEXINPUTS=.:..:../refman:../library:../cmds:../tutorials:../../styles:
+TEXFONTS=../../styles:
+RELEASE=$$HOME/release/$${RELEASENAME}
+HEVEA=hevea
+HACHA=hacha
+INFO=-fix -exec xxdate.exe -info -w 79
+HTML=-fix -exec xxdate.exe -O
+TEXT=-fix -exec xxdate.exe -text -w 79
+SRC = $(abspath ../../)
+
+export LD_LIBRARY_PATH ?= $(SRC)/otherlibs/unix/:$(SRC)/otherlibs/str/
+export DYLD_LIBRARY_PATH ?= $(SRC)/otherlibs/unix/:$(SRC)/otherlibs/str/
+SET_LD_PATH=CAML_LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)
+
+OCAMLDOC=$(if $(wildcard $(SRC)/ocamldoc/ocamldoc.opt),\
+ $(SRC)/ocamldoc/ocamldoc.opt,\
+ $(SET_LD_PATH) $(SRC)/byterun/ocamlrun $(SRC)/ocamldoc/ocamldoc)\
+ -hide Pervasives -nostdlib -initially-opened-module Pervasives
+
+manual: files
+ cd texstuff; \
+ TEXINPUTS=$(TEXINPUTS) latex manual.tex
+
+index::
+ cd texstuff && \
+ sh ../../tools/fix_index.sh manual.idx && \
+ makeindex manual.idx
+ cd texstuff; makeindex manual.kwd.idx
+
+pdfmanual: files
+ cd texstuff; \
+ TEXINPUTS=$(TEXINPUTS) pdflatex pdfmanual.tex
+
+index::
+ cd texstuff && \
+ sh ../../tools/fix_index.sh pdfmanual.idx && \
+ makeindex pdfmanual.idx
+ cd texstuff; makeindex pdfmanual.kwd.idx
+
+
+# Copy and unprefix the standard library when needed
+include $(SRC)/ocamldoc/Makefile.unprefix
+
+html: files $(STDLIB_CMIS)
+ cd htmlman; \
+ mkdir -p libref ; \
+ $(OCAMLDOC) -colorize-code -sort -html \
+ -d libref \
+ -I $(STDLIB_UNPREFIXED) \
+ $(STDLIB_MLIS) ; \
+ cp -f ../style.css libref ; \
+ ${HEVEA} ${HTML} -I .. -I ../refman -I ../library -I ../cmds \
+ -I ../tutorials -I ../../styles -I ../texstuff manual.hva \
+ -e macros.tex ../manual.tex ; \
+ ${HACHA} -tocter manual.html ; \
+
+info: files
+ cd infoman; rm -f ocaml.info*; \
+ ${HEVEA} ${INFO} -o ocaml.info.body -I .. -I ../refman -I ../library \
+ -I ../cmds -I ../tutorials -I ../../styles -I ../texstuff \
+ ../manual.inf -e macros.tex ../manual.tex
+ cat manual.info.header infoman/ocaml.info.body > infoman/ocaml.info
+ cd infoman; rm -f ocaml.info.tmp ocaml.info.body ; gzip -9 ocaml.info*
+
+text: files
+ cd textman; \
+ ${HEVEA} ${TEXT} -I .. -I ../refman -I ../library -I ../cmds \
+ -I ../tutorials -I ../../styles -I ../texstuff \
+ ../manual.inf -e macros.tex ../manual.tex
+
+etex-files: $(FILES)
+ cd refman; $(MAKE) etex-files RELEASEDIR=$(SRC)
+ cd library; $(MAKE) etex-files RELEASEDIR=$(SRC)
+ cd cmds; $(MAKE) etex-files RELEASEDIR=$(SRC)
+ cd tutorials; $(MAKE) etex-files RELEASEDIR=$(SRC)
+
+files: $(FILES)
+ cd refman; $(MAKE) all RELEASEDIR=$(SRC)
+ cd library; $(MAKE) all RELEASEDIR=$(SRC)
+ cd cmds; $(MAKE) all RELEASEDIR=$(SRC)
+ cd tutorials; $(MAKE) all RELEASEDIR=$(SRC)
+
+all:
+ $(MAKE) manual pdfmanual RELEASEDIR=$(SRC)
+ $(MAKE) manual pdfmanual RELEASEDIR=$(SRC)
+ $(MAKE) index RELEASEDIR=$(SRC)
+ $(MAKE) manual pdfmanual RELEASEDIR=$(SRC)
+ $(MAKE) html text info RELEASEDIR=$(SRC)
+
+clean:
+ rm -f $(FILES)
+ cd refman; $(MAKE) clean
+ cd library; $(MAKE) clean
+ cd cmds; $(MAKE) clean
+ cd tutorials; $(MAKE) clean
+ -rm -f texstuff/*
+ cd htmlman; rm -rf libref index.html manual*.html *.haux *.hind
+ cd textman; rm -f manual.txt *.haux *.hind
+ cd infoman; rm -f ocaml.info ocaml.info-* *.haux *.hind
+ rm -f warnings-help.etex
+
+release:
+ gzip < texstuff/manual.dvi > $(RELEASE)refman.dvi.gz
+ dvips -o '!gzip > $(RELEASE)refman.ps.gz' texstuff/manual.dvi
+ cp htmlman/manual.html $(RELEASE)refman.html
+ rm -f htmlman/manual.{html,haux,hmanual*,htoc}
+ tar zcf $(RELEASE)refman-html.tar.gz htmlman/*.* htmlman/libref
+ zip -8 $(RELEASE)refman-html.zip htmlman/*.* htmlman/libref/*.*
+ cp texstuff/pdfmanual.pdf $(RELEASE)refman.pdf
+ cp textman/manual.txt $(RELEASE)refman.txt
+ tar cf - infoman/ocaml.info* | gzip > $(RELEASE)refman.info.tar.gz
+
+.SUFFIXES:
+.SUFFIXES: .tex .etex .htex
+
+
+.etex.tex:
+ ../tools/texquote2 < $*.etex > $*.tex
+
+version.tex: $(SRC)/VERSION
+ sed -n -e '1s/^\([0-9]*\.[0-9]*\).*$$/\\def\\ocamlversion{\1}/p' \
+ $(SRC)/VERSION > version.tex
+
+warnings-help.etex: $(SRC)/utils/warnings.ml $(SRC)/ocamlc
+ (echo "% This file is generated from (ocamlc -warn-help)";\
+ echo "% according to a rule in manual/manual/Makefile.";\
+ echo "% In particular, the reference to documentation sections";\
+ echo "% are inserted through the Makefile, which should be updated";\
+ echo "% when a new warning is documented.";\
+ echo "%";\
+ $(SET_LD_PATH) $(SRC)/boot/ocamlrun $(SRC)/ocamlc -warn-help \
+ | sed -e 's/^ *\([0-9A-Z][0-9]*\)\(.*\)/\\item[\1] \2/'\
+ ) >$@
+# sed --inplace is not portable, emulate
+ for i in 52 57; do\
+ sed\
+ s'/\\item\['$$i'\]/\\item\['$$i' (see \\ref{ss:warn'$$i'})\]/'\
+ $@ > $@.tmp;\
+ mv $@.tmp $@;\
+ done
--- /dev/null
+\makeindex{\jobname}
+\makeindex{\jobname.kwd}
+
+\setlength{\emergencystretch}{50pt} % pour que TeX resolve les overfull hbox lui-meme
+
+\begin{document}
+
+\thispagestyle{empty}
+\begin{maintitle}
+~\vfill
+\Huge The OCaml system \\
+ release \ocamlversion \\[1cm]
+\Large Documentation and user's manual \\[1cm]
+\large Xavier Leroy, \\
+ Damien Doligez, Alain Frisch, Jacques Garrigue, Didier Rémy and Jérôme Vouillon \\[1cm]
+ \today \\
+ ~
+\vfill
+\normalsize Copyright \copyright\ \number\year\ Institut National de
+ Recherche en Informatique et en Automatique
+\end{maintitle}
+\cleardoublepage
+\setcounter{page}{1}
+
+
+\begin{htmlonly}
+\begin{quote}
+\rule{}{}
+This manual is also available in
+\ahref{http://caml.inria.fr/distrib/ocaml-\ocamlversion/ocaml-\ocamlversion-refman.pdf}{PDF}.
+\ahref{http://caml.inria.fr/distrib/ocaml-\ocamlversion/ocaml-\ocamlversion-refman.ps.gz}{Postscript},
+\ahref{http://caml.inria.fr/distrib/ocaml-\ocamlversion/ocaml-\ocamlversion-refman.dvi.gz}{DVI},
+\ahref{http://caml.inria.fr/distrib/ocaml-\ocamlversion/ocaml-\ocamlversion-refman.txt}{plain text},
+as a
+\ahref{http://caml.inria.fr/distrib/ocaml-\ocamlversion/ocaml-\ocamlversion-refman-html.tar.gz}{bundle of HTML files},
+and as a
+\ahref{http://caml.inria.fr/distrib/ocaml-\ocamlversion/ocaml-\ocamlversion-refman.info.tar.gz}{bundle of Emacs Info files}.
+\rule{}{}
+\end{quote}
+\end{htmlonly}
+
+\tableofcontents
+
+\input{foreword.tex}
+
+\part{An introduction to OCaml}
+\label{p:tutorials}
+\input{coreexamples.tex}
+\input{moduleexamples.tex}
+\input{objectexamples.tex}
+\input{lablexamples.tex}
+\input{polymorphism.tex}
+\input{advexamples.tex}
+
+\part{The OCaml language}
+\label{p:refman}
+\input{refman.tex}
+\input{exten.tex}
+
+\part{The OCaml tools}
+\label{p:commands}
+
+\input{comp.tex}
+\input{top.tex}
+\input{runtime.tex}
+\input{native.tex}
+\input{lexyacc.tex}
+\input{depend.tex}
+\input{browser.tex}
+\input{ocamldoc.tex}
+\input{debugger.tex}
+\input{profil.tex}
+\input{ocamlbuild.tex}
+% \input emacs.tex
+\input{intf-c.tex}
+\input{flambda.tex}
+\input{spacetime.tex}
+\input{afl-fuzz.tex}
+\input{plugins}
+
+\part{The OCaml library}
+\label{p:library}
+\input{core.tex}
+\input{stdlib.tex}
+\input{compilerlibs.tex}
+\input{libunix.tex}
+\input{libnum.tex}
+\input{libstr.tex}
+\input{libthreads.tex}
+\input{libgraph.tex}
+\input{libdynlink.tex}
+\input{libbigarray.tex}
+
+\part{Appendix}
+\label{p:appendix}
+
+\ifouthtml
+\begin{links}
+\item \ahref{libref/index_modules.html}{Index of modules}
+\item \ahref{libref/index_module_types.html}{Index of module types}
+\item \ahref{libref/index_types.html}{Index of types}
+\item \ahref{libref/index_exceptions.html}{Index of exceptions}
+\item \ahref{libref/index_values.html}{Index of values}
+\end{links}
+\else
+\printindex{\jobname}{Index to the library}
+\fi
+\printindex{\jobname.kwd}{Index of keywords}
+
+\end{document}
--- /dev/null
+\chapter{Further reading}
+
+For the interested reader, we list below some references to books and
+reports related (sometimes loosely) to Caml Light.
+
+\section{Programming in ML}
+
+The books below are programming courses taught in ML. Their main goal
+is to teach programming, not to describe ML in full details --- though
+most contain fairly good introductions to the ML language. Some of
+those books use the Standard ML dialect instead of the Caml dialect,
+so you will have to keep in mind the differences in syntax and in
+semantics.
+
+\begin{itemize}
+
+\item Pierre Weis and Xavier Leroy. {\it Le langage Caml.}
+InterÉditions, 1993.
+
+The natural companion to this manual, provided you read French. This
+book is a step-by-step introduction to programming in Caml, and
+presents many realistic examples of Caml programs.
+
+\item Guy Cousineau and Michel Mauny. {\it Approche fonctionnelle de
+la programmation}. Ediscience, 1995.
+
+Another Caml programming course written in French, with many original
+examples.
+
+\item Lawrence C.\ Paulson. {\it ML for the working programmer.}
+Cambridge University Press, 1991.
+
+A good introduction to programming in Standard ML. Develops a
+theorem prover as a complete example. Contains a presentation of
+the module system of Standard ML.
+
+\item Jeffrey D.\ Ullman. {\it Elements of ML programming.}
+Prentice Hall, 1993.
+
+Another good introduction to programming in Standard ML. No realistic
+examples, but a very detailed presentation of the language constructs.
+
+\item Ryan Stansifer. {\em ML primer.} Prentice-Hall, 1992.
+
+A short, but nice introduction to programming in Standard ML.
+
+\item Thérèse Accart Hardin and Véronique Donzeau-Gouge Viguié. {\em
+Concepts et outils de la programmation. Du fonctionnel à
+l'impératif avec Caml et Ada.} InterÉditions, 1992.
+
+A first course in programming, that first introduces the main programming
+notions in Caml, then shows them underlying Ada. Intended for
+beginners; slow-paced for the others.
+
+\item Rachel Harrison. {\em Abstract Data Types in Standard ML}.
+John Wiley \& Sons, 1993.
+
+A presentation of Standard ML from the standpoint of abstract data
+types. Uses intensively the Standard ML module system.
+
+\item Harold Abelson and Gerald Jay Sussman.
+{\em Structure and Interpretation of Computer Programs.} The MIT
+press, 1985. (French translation: {\em Structure et interprétation
+des programmes informatiques}, InterÉditions, 1989.)
+
+An outstanding course on programming, taught in Scheme, the modern
+dialect of Lisp. Well worth reading, even if you are more interested
+in ML than in Lisp.
+
+\end{itemize}
+
+\section{Descriptions of ML dialects}
+
+The books and reports below are descriptions of various programming
+languages from the ML family. They assume some familiarity with ML.
+
+\begin{itemize}
+
+\item Xavier Leroy and Pierre Weis. {\em Manuel de référence du
+langage Caml.} InterÉditions, 1993.
+
+The French edition of the present reference manual and user's manual.
+
+\item Robert Harper. {\em Introduction to Standard ML.} Technical
+report ECS-LFCS-86-14, University of Edinburgh, 1986.
+
+An overview of Standard ML, including the module system. Terse, but
+still readable.
+
+\item Robin Milner, Mads Tofte and Robert Harper. {\em The definition
+of Standard ML.} The MIT press, 1990.
+
+A complete formal definition of Standard ML, in the framework of
+structured operational semantics. This book is probably the most
+mathematically precise definition of a programming language ever
+written. It is heavy on formalism and extremely terse, so
+even readers who are thoroughly familiar with ML will have
+major difficulties with it.
+
+\item Robin Milner and Mads Tofte. {\em Commentary on Standard ML.}
+The MIT Press, 1991.
+
+A commentary on the book above, that attempts to explain the most
+delicate parts and motivate the design choices. Easier to read than the
+Definition, but still rather involving.
+
+\item Guy Cousineau and Gérard Huet. {\em The CAML primer.} Technical
+report~122, INRIA, 1990.
+
+A short description of the original Caml system, from which Caml Light
+has evolved. Some familiarity with Lisp is assumed.
+
+\item Pierre Weis et al. {\em The CAML reference manual, version
+2.6.1.} Technical report~121, INRIA, 1990.
+
+The manual for the original Caml system, from which Caml Light
+has evolved.
+
+\item Michael J.\ Gordon, Arthur J.\ Milner and Christopher P.\ Wadsworth.
+{\em Edinburgh LCF.} Lecture Notes in Computer Science
+volume~78, Springer-Verlag, 1979.
+
+This is the first published description of the ML language, at the
+time when it was nothing more than the control language for the LCF
+system, a theorem prover. This book is now obsolete, since the ML
+language has much evolved since then; but it is still of historical
+interest.
+
+\item Paul Hudak, Simon Peyton-Jones and Philip Wadler. {\em
+Report on the programming language Haskell, version 1.1.} Technical
+report, Yale University, 1991.
+
+Haskell is a purely functional language with lazy semantics that
+shares many important points with ML (full functionality, polymorphic
+typing), but has interesting features of its own (dynamic overloading,
+also called type classes).
+
+\end{itemize}
+
+\section{Implementing functional programming languages}
+
+The references below are intended for those who are curious to learn
+how a language like Caml Light is compiled and implemented.
+
+\begin{itemize}
+
+\item Xavier Leroy. {\em The ZINC experiment: an economical
+implementation of the ML language.} Technical report~117, INRIA, 1990.
+(Available by anonymous FTP on "ftp.inria.fr".)
+
+A description of the ZINC implementation, the prototype ML
+implementation that has evolved into Caml Light. Large parts of this
+report still apply to the current Caml Light system, in particular the
+description of the execution model and abstract machine. Other parts
+are now obsolete. Yet this report still gives a complete overview of the
+implementation techniques used in Caml Light.
+
+\item Simon Peyton-Jones. {\em The implementation of functional
+programming languages.} Prentice-Hall, 1987. (French translation:
+{\em Mise en \oe uvre des langages fonctionnels de programmation},
+Masson, 1990.)
+
+An excellent description of the implementation of purely functional
+languages with lazy semantics, using the technique known as graph
+reduction. The part of the book that deals with the transformation
+from ML to enriched lambda-calculus directly applies to Caml Light.
+You will find a good description of how pattern-matching is compiled
+and how types are inferred. The remainder of the book does not apply
+directly to Caml Light, since Caml Light is not purely functional (it
+has side-effects), has strict semantics, and does not use graph
+reduction at all.
+
+\item Andrew W.\ Appel. {\em Compiling with continuations.} Cambridge
+University Press, 1992.
+
+A complete description of an optimizing compiler for Standard ML,
+based on an intermediate representation called continuation-passing
+style. Shows how many advanced program optimizations can be applied to
+ML. Not directly relevant to the Caml Light system, since Caml Light
+does not use continuation-passing style at all, and makes little
+attempts at optimizing programs.
+
+\end{itemize}
+
+\section{Applications of ML}
+
+The following reports show ML at work in various, sometimes
+unexpected, areas.
+
+\begin{itemize}
+
+\item Emmanuel Chailloux and Guy Cousineau. {\em The MLgraph primer.}
+Technical report 92-15, École Normale Supérieure, 1992. (Available by
+anonymous FTP on "ftp.ens.fr".)
+%, répertoire "biblio", fichier
+% "liens-92-15.A4.300dpi.ps.Z".)
+
+Describes a Caml Light library that produces Postscript pictures
+through high-level drawing functions.
+
+\item Xavier Leroy. {\em Programmation du système Unix en Caml Light.}
+Technical report~147, INRIA, 1992. (Available by anonymous FTP on
+"ftp.inria.fr".)
+%, répertoire "INRIA/publication", fichier "RT-0147.ps.Z".)
+
+A Unix systems programming course, demonstrating the use of the Caml
+Light library that gives access to Unix system calls.
+
+\item John H.\ Reppy. {\em Concurrent programming with events --- The
+concurrent ML manual.} Cornell University, 1990.
+(Available by anonymous FTP on "research.att.com".)
+%, répertoire "dist/ml", fichier "CML-0.9.8.tar.Z".)
+
+Concurrent ML extends Standard ML of New Jersey with concurrent
+processes that communicate through channels and events.
+
+\item Jeannette M. Wing, Manuel Faehndrich, J.\ Gregory Morrisett and
+Scottt Nettles. {\em Extensions to Standard ML to support
+transactions.} Technical report CMU-CS-92-132, Carnegie-Mellon
+University, 1992. (Available by anonymous FTP on
+"reports.adm.cs.cmu.edu".)
+% , répertoire "1992", fichier "CMU-CS-92-132.ps".)
+
+How to integrate the basic database operations to Standard ML.
+
+\item Emden R.\ Gansner and John H.\ Reppy. {\em eXene.} Bell Labs,
+1991. (Available by anonymous FTP on "research.att.com".)
+%, répertoire "dist/ml", fichier "eXene-0.4.tar.Z".)
+
+An interface between Standard ML of New Jersey and the X Windows
+windowing system.
+
+%% \item Daniel de Rauglaudre. {\em X toolkit in Caml Light.} INRIA,
+%% 1992. (Included in the Caml Light distribution.)
+%% % Disponible par FTP anonyme sur
+%% % "ftp.inria.fr", répertoire "lang/caml-light", fichier "rt5.tar.Z".)
+%%
+%% An interface between Caml Light and the X Windows windowing system.
+
+\end{itemize}
--- /dev/null
+*.tex
+*.htex
+warnings.etex
--- /dev/null
+FILES=comp.tex top.tex runtime.tex native.tex lexyacc.tex intf-c.tex \
+ depend.tex profil.tex debugger.tex browser.tex ocamldoc.tex \
+ warnings-help.tex ocamlbuild.tex flambda.tex spacetime.tex \
+ afl-fuzz.tex plugins.tex unified-options.tex
+
+TOPDIR=../../..
+include $(TOPDIR)/Makefile.tools
+
+LD_PATH="$(TOPDIR)/otherlibs/str:$(TOPDIR)/otherlibs/unix"
+
+TRANSF=$(SET_LD_PATH) $(OCAMLRUN) ../../tools/transf
+TEXQUOTE=../../tools/texquote2
+FORMAT=../../tools/format-intf
+
+CAMLLATEX=$(SET_LD_PATH) $(OCAMLRUN) ../../tools/caml-tex2 \
+-caml "TERM=norepeat $(OCAML)" -n 80 -v false
+
+WITH_TRANSF= top.tex intf-c.tex flambda.tex spacetime.tex \
+ afl-fuzz.tex lexyacc.tex debugger.tex
+
+WITH_CAMLEXAMPLE = ocamldoc.tex
+
+etex-files: $(FILES)
+
+all: $(FILES)
+
+clean::
+ rm -f $(FILES)
+ rm -f *~ #*#
+
+.SUFFIXES:
+.SUFFIXES: .tex .etex
+
+.etex.tex:
+ @$(TEXQUOTE) < $*.etex > $*.texquote_error.tex\
+ && mv $*.texquote_error.tex $*.tex\
+ || printf "Failure when generating %s\n" $*.tex
+
+$(WITH_TRANSF):%.tex:%.etex
+ @$(TRANSF) < $*.etex > $*.transf_error.tex \
+ && mv $*.transf_error.tex $*.transf_gen.tex \
+ && $(TEXQUOTE) < $*.transf_gen.tex > $*.texquote_error.tex \
+ && mv $*.texquote_error.tex $*.tex \
+ || printf "Failure when generating %s\n" $*.tex
+
+
+$(WITH_CAMLEXAMPLE):%.tex:%.etex
+ @$(CAMLLATEX) -o $*.caml_tex_error.tex $*.etex \
+ && mv $*.caml_tex_error.tex $*.gen.tex \
+ && $(TRANSF) < $*.gen.tex > $*.transf_error.tex \
+ && mv $*.transf_error.tex $*.gen.tex\
+ && $(TEXQUOTE) < $*.gen.tex > $*.texquote_error.tex\
+ && mv $*.texquote_error.tex $*.tex\
+ || printf "Failure when generating %s\n" $*.tex
+
+warnings-help.etex: ../warnings-help.etex
+ cp ../warnings-help.etex .
+
+clean::
+ rm -f warnings-help.etex
--- /dev/null
+\chapter{Fuzzing with afl-fuzz}
+\pdfchapterfold{-9}{Fuzzing with afl-fuzz}
+%HEVEA\cutname{afl-fuzz.html}
+
+\section{Overview}
+
+American fuzzy lop (``afl-fuzz'') is a {\em fuzzer}, a tool for
+testing software by providing randomly-generated inputs, searching for
+those inputs which cause the program to crash.
+
+Unlike most fuzzers, afl-fuzz observes the internal behaviour of the
+program being tested, and adjusts the test cases it generates to
+trigger unexplored execution paths. As a result, test cases generated
+by afl-fuzz cover more of the possible behaviours of the tested
+program than other fuzzers.
+
+This requires that programs to be tested are instrumented to
+communicate with afl-fuzz. The native-code compiler ``ocamlopt'' can
+generate such instrumentation, allowing afl-fuzz to be used against
+programs written in OCaml.
+
+For more information on afl-fuzz, see the website at
+\ifouthtml
+\ahref{http://lcamtuf.coredump.cx/afl/}{http://lcamtuf.coredump.cx/afl/}.
+\else
+{\tt http://lcamtuf.coredump.cx/afl/}
+\fi
+
+\section{Generating instrumentation}
+
+The instrumentation that afl-fuzz requires is not generated by
+default, and must be explicitly enabled, by passing the {\tt
+ -afl-instrument} option to {\tt ocamlopt}.
+
+To fuzz a large system without modifying build tools, OCaml's {\tt
+ configure} script also accepts the {\tt afl-instrument} option. If
+OCaml is configured with {\tt afl-instrument}, then all programs
+compiled by {\tt ocamlopt} will be instrumented.
+
+\subsection{Advanced options}
+
+In rare cases, it is useful to control the amount of instrumentation
+generated. By passing the {\tt -afl-inst-ratio N} argument to {\tt
+ ocamlopt} with {\tt N} less than 100, instrumentation can be
+generated for only N\% of branches. (See the afl-fuzz documentation on
+the parameter {\tt AFL\_INST\_RATIO} for the precise effect of this).
+
+\section{Example}
+
+As an example, we fuzz-test the following program, {\tt readline.ml}:
+
+\begin{verbatim}
+let _ =
+ let s = read_line () in
+ match Array.to_list (Array.init (String.length s) (String.get s)) with
+ ['s'; 'e'; 'c'; 'r'; 'e'; 't'; ' '; 'c'; 'o'; 'd'; 'e'] -> failwith "uh oh"
+ | _ -> ()
+\end{verbatim}
+
+There is a single input (the string ``secret code'') which causes this
+program to crash, but finding it by blind random search is infeasible.
+
+Instead, we compile with afl-fuzz instrumentation enabled:
+\begin{verbatim}
+ocamlopt -afl-instrument readline.ml -o readline
+\end{verbatim}
+Next, we run the program under afl-fuzz:
+\begin{verbatim}
+mkdir input
+echo asdf > input/testcase
+mkdir output
+afl-fuzz -i input -o output ./readline
+\end{verbatim}
+By inspecting instrumentation output, the fuzzer finds the crashing input quickly.
--- /dev/null
+\chapter{The browser/editor (ocamlbrowser)} \label{c:browser}
+\pdfchapter{The browser/editor (ocamlbrowser)}
+%HEVEA\cutname{browser.html}
+
+Since OCaml version 4.02, the OCamlBrowser tool and the Labltk library
+are distributed separately from the OCaml compiler. The project is now
+hosted at \url{https://forge.ocamlcore.org/projects/labltk/}.
--- /dev/null
+\chapter{Batch compilation (ocamlc)} \label{c:camlc}
+\pdfchapter{Batch compilation (ocamlc)}
+%HEVEA\cutname{comp.html}
+
+This chapter describes the OCaml batch compiler "ocamlc",
+which compiles OCaml source files to bytecode object files and links
+these object files to produce standalone bytecode executable files.
+These executable files are then run by the bytecode interpreter
+"ocamlrun".
+
+\section{Overview of the compiler}
+
+The "ocamlc" command has a command-line interface similar to the one of
+most C compilers. It accepts several types of arguments and processes them
+sequentially, after all options have been processed:
+
+\begin{itemize}
+\item
+Arguments ending in ".mli" are taken to be source files for
+compilation unit interfaces. Interfaces specify the names exported by
+compilation units: they declare value names with their types, define
+public data types, declare abstract data types, and so on. From the
+file \var{x}".mli", the "ocamlc" compiler produces a compiled interface
+in the file \var{x}".cmi".
+
+\item
+Arguments ending in ".ml" are taken to be source files for compilation
+unit implementations. Implementations provide definitions for the
+names exported by the unit, and also contain expressions to be
+evaluated for their side-effects. From the file \var{x}".ml", the "ocamlc"
+compiler produces compiled object bytecode in the file \var{x}".cmo".
+
+If the interface file \var{x}".mli" exists, the implementation
+\var{x}".ml" is checked against the corresponding compiled interface
+\var{x}".cmi", which is assumed to exist. If no interface
+\var{x}".mli" is provided, the compilation of \var{x}".ml" produces a
+compiled interface file \var{x}".cmi" in addition to the compiled
+object code file \var{x}".cmo". The file \var{x}".cmi" produced
+corresponds to an interface that exports everything that is defined in
+the implementation \var{x}".ml".
+
+\item
+Arguments ending in ".cmo" are taken to be compiled object bytecode. These
+files are linked together, along with the object files obtained
+by compiling ".ml" arguments (if any), and the OCaml standard
+library, to produce a standalone executable program. The order in
+which ".cmo" and ".ml" arguments are presented on the command line is
+relevant: compilation units are initialized in that order at
+run-time, and it is a link-time error to use a component of a unit
+before having initialized it. Hence, a given \var{x}".cmo" file must come
+before all ".cmo" files that refer to the unit \var{x}.
+
+\item
+Arguments ending in ".cma" are taken to be libraries of object bytecode.
+A library of object bytecode packs in a single file a set of object
+bytecode files (".cmo" files). Libraries are built with "ocamlc -a"
+(see the description of the "-a" option below). The object files
+contained in the library are linked as regular ".cmo" files (see
+above), in the order specified when the ".cma" file was built. The
+only difference is that if an object file contained in a library is
+not referenced anywhere in the program, then it is not linked in.
+
+\item
+Arguments ending in ".c" are passed to the C compiler, which generates
+a ".o" object file (".obj" under Windows). This object file is linked
+with the program if the "-custom" flag is set (see the description of
+"-custom" below).
+
+\item
+Arguments ending in ".o" or ".a" (".obj" or ".lib" under Windows)
+are assumed to be C object files and libraries. They are passed to the
+C linker when linking in "-custom" mode (see the description of
+"-custom" below).
+
+\item
+Arguments ending in ".so" (".dll" under Windows)
+are assumed to be C shared libraries (DLLs). During linking, they are
+searched for external C functions referenced from the OCaml code,
+and their names are written in the generated bytecode executable.
+The run-time system "ocamlrun" then loads them dynamically at program
+start-up time.
+
+\end{itemize}
+
+The output of the linking phase is a file containing compiled bytecode
+that can be executed by the OCaml bytecode interpreter:
+the command named "ocamlrun". If "a.out" is the name of the file
+produced by the linking phase, the command
+\begin{alltt}
+ ocamlrun a.out \nth{arg}{1} \nth{arg}{2} \ldots \nth{arg}{n}
+\end{alltt}
+executes the compiled code contained in "a.out", passing it as
+arguments the character strings \nth{arg}{1} to \nth{arg}{n}.
+(See chapter~\ref{c:runtime} for more details.)
+
+On most systems, the file produced by the linking
+phase can be run directly, as in:
+\begin{alltt}
+ ./a.out \nth{arg}{1} \nth{arg}{2} \ldots \nth{arg}{n}
+\end{alltt}
+The produced file has the executable bit set, and it manages to launch
+the bytecode interpreter by itself.
+
+\section{Options}\label{s:comp-options}
+
+The following command-line options are recognized by "ocamlc".
+The options "-pack", "-a", "-c" and "-output-obj" are mutually exclusive.
+% Define boolean variables used by the macros in unified-options.etex
+\newif\ifcomp \comptrue
+\newif\ifnat \natfalse
+\newif\iftop \topfalse
+% unified-options gathers all options across the native/bytecode
+% compilers and toplevel
+\input{unified-options.tex}
+
+\paragraph{Contextual control of command-line options}
+
+The compiler command line can be modified ``from the outside''
+with the following mechanisms. These are experimental
+and subject to change. They should be used only for experimental and
+development work, not in released packages.
+
+\begin{options}
+\item["OCAMLPARAM" \rm(environment variable)]
+A set of arguments that will be inserted before or after the arguments from
+the command line. Arguments are specified in a comma-separated list
+of "name=value" pairs. A "_" is used to specify the position of
+the command line arguments, i.e. "a=x,_,b=y" means that "a=x" should be
+executed before parsing the arguments, and "b=y" after. Finally,
+an alternative separator can be specified as the
+first character of the string, within the set ":|; ,".
+\item["ocaml_compiler_internal_params" \rm(file in the stdlib directory)]
+A mapping of file names to lists of arguments that
+will be added to the command line (and "OCAMLPARAM") arguments.
+\item["OCAML_FLEXLINK" \rm(environment variable)]
+Alternative executable to use on native
+Windows for "flexlink" instead of the
+configured value. Primarily used for bootstrapping.
+\end{options}
+
+\section{Modules and the file system}
+
+This short section is intended to clarify the relationship between the
+names of the modules corresponding to compilation units and the names
+of the files that contain their compiled interface and compiled
+implementation.
+
+The compiler always derives the module name by taking the capitalized
+base name of the source file (".ml" or ".mli" file). That is, it
+strips the leading directory name, if any, as well as the ".ml" or
+".mli" suffix; then, it set the first letter to uppercase, in order to
+comply with the requirement that module names must be capitalized.
+For instance, compiling the file "mylib/misc.ml" provides an
+implementation for the module named "Misc". Other compilation units
+may refer to components defined in "mylib/misc.ml" under the names
+"Misc."\var{name}; they can also do "open Misc", then use unqualified
+names \var{name}.
+
+The ".cmi" and ".cmo" files produced by the compiler have the same
+base name as the source file. Hence, the compiled files always have
+their base name equal (modulo capitalization of the first letter) to
+the name of the module they describe (for ".cmi" files) or implement
+(for ".cmo" files).
+
+When the compiler encounters a reference to a free module identifier
+"Mod", it looks in the search path for a file named "Mod.cmi" or "mod.cmi"
+and loads the compiled interface
+contained in that file. As a consequence, renaming ".cmi" files is not
+advised: the name of a ".cmi" file must always correspond to the name
+of the compilation unit it implements. It is admissible to move them
+to another directory, if their base name is preserved, and the correct
+"-I" options are given to the compiler. The compiler will flag an
+error if it loads a ".cmi" file that has been renamed.
+
+Compiled bytecode files (".cmo" files), on the other hand, can be
+freely renamed once created. That's because the linker never attempts
+to find by itself the ".cmo" file that implements a module with a
+given name: it relies instead on the user providing the list of ".cmo"
+files by hand.
+
+\section{Common errors} \label{s:comp-errors}
+
+This section describes and explains the most frequently encountered
+error messages.
+
+\begin{options}
+
+\item[Cannot find file \var{filename}]
+The named file could not be found in the current directory, nor in the
+directories of the search path. The \var{filename} is either a
+compiled interface file (".cmi" file), or a compiled bytecode file
+(".cmo" file). If \var{filename} has the format \var{mod}".cmi", this
+means you are trying to compile a file that references identifiers
+from module \var{mod}, but you have not yet compiled an interface for
+module \var{mod}. Fix: compile \var{mod}".mli" or \var{mod}".ml"
+first, to create the compiled interface \var{mod}".cmi".
+
+If \var{filename} has the format \var{mod}".cmo", this
+means you are trying to link a bytecode object file that does not
+exist yet. Fix: compile \var{mod}".ml" first.
+
+If your program spans several directories, this error can also appear
+because you haven't specified the directories to look into. Fix: add
+the correct "-I" options to the command line.
+
+\item[Corrupted compiled interface \var{filename}]
+The compiler produces this error when it tries to read a compiled
+interface file (".cmi" file) that has the wrong structure. This means
+something went wrong when this ".cmi" file was written: the disk was
+full, the compiler was interrupted in the middle of the file creation,
+and so on. This error can also appear if a ".cmi" file is modified after
+its creation by the compiler. Fix: remove the corrupted ".cmi" file,
+and rebuild it.
+
+\item[This expression has type \nth{t}{1}, but is used with type \nth{t}{2}]
+This is by far the most common type error in programs. Type \nth{t}{1} is
+the type inferred for the expression (the part of the program that is
+displayed in the error message), by looking at the expression itself.
+Type \nth{t}{2} is the type expected by the context of the expression; it
+is deduced by looking at how the value of this expression is used in
+the rest of the program. If the two types \nth{t}{1} and \nth{t}{2} are not
+compatible, then the error above is produced.
+
+In some cases, it is hard to understand why the two types \nth{t}{1} and
+\nth{t}{2} are incompatible. For instance, the compiler can report that
+``expression of type "foo" cannot be used with type "foo"'', and it
+really seems that the two types "foo" are compatible. This is not
+always true. Two type constructors can have the same name, but
+actually represent different types. This can happen if a type
+constructor is redefined. Example:
+\begin{verbatim}
+ type foo = A | B
+ let f = function A -> 0 | B -> 1
+ type foo = C | D
+ f C
+\end{verbatim}
+This result in the error message ``expression "C" of type "foo" cannot
+be used with type "foo"''.
+
+\item[The type of this expression, \var{t}, contains type variables
+ that cannot be generalized]
+Type variables ("'a", "'b", \ldots) in a type \var{t} can be in either
+of two states: generalized (which means that the type \var{t} is valid
+for all possible instantiations of the variables) and not generalized
+(which means that the type \var{t} is valid only for one instantiation
+of the variables). In a "let" binding "let "\var{name}" = "\var{expr},
+the type-checker normally generalizes as many type variables as
+possible in the type of \var{expr}. However, this leads to unsoundness
+(a well-typed program can crash) in conjunction with polymorphic
+mutable data structures. To avoid this, generalization is performed at
+"let" bindings only if the bound expression \var{expr} belongs to the
+class of ``syntactic values'', which includes constants, identifiers,
+functions, tuples of syntactic values, etc. In all other cases (for
+instance, \var{expr} is a function application), a polymorphic mutable
+could have been created and generalization is therefore turned off for
+all variables occurring in contravariant or non-variant branches of the
+type. For instance, if the type of a non-value is "'a list" the
+variable is generalizable ("list" is a covariant type constructor),
+but not in "'a list -> 'a list" (the left branch of "->" is
+contravariant) or "'a ref" ("ref" is non-variant).
+
+Non-generalized type variables in a type cause no difficulties inside
+a given structure or compilation unit (the contents of a ".ml" file,
+or an interactive session), but they cannot be allowed inside
+signatures nor in compiled interfaces (".cmi" file), because they
+could be used inconsistently later. Therefore, the compiler
+flags an error when a structure or compilation unit defines a value
+\var{name} whose type contains non-generalized type variables. There
+are two ways to fix this error:
+\begin{itemize}
+\item Add a type constraint or a ".mli" file to give a monomorphic
+type (without type variables) to \var{name}. For instance, instead of
+writing
+\begin{verbatim}
+ let sort_int_list = Sort.list (<)
+ (* inferred type 'a list -> 'a list, with 'a not generalized *)
+\end{verbatim}
+write
+\begin{verbatim}
+ let sort_int_list = (Sort.list (<) : int list -> int list);;
+\end{verbatim}
+\item If you really need \var{name} to have a polymorphic type, turn
+its defining expression into a function by adding an extra parameter.
+For instance, instead of writing
+\begin{verbatim}
+ let map_length = List.map Array.length
+ (* inferred type 'a array list -> int list, with 'a not generalized *)
+\end{verbatim}
+write
+\begin{verbatim}
+ let map_length lv = List.map Array.length lv
+\end{verbatim}
+\end{itemize}
+
+\item[Reference to undefined global \var{mod}]
+This error appears when trying to link an incomplete or incorrectly
+ordered set of files. Either you have forgotten to provide an
+implementation for the compilation unit named \var{mod} on the command line
+(typically, the file named \var{mod}".cmo", or a library containing
+that file). Fix: add the missing ".ml" or ".cmo" file to the command
+line. Or, you have provided an implementation for the module named
+\var{mod}, but it comes too late on the command line: the
+implementation of \var{mod} must come before all bytecode object files
+that reference \var{mod}. Fix: change the order of ".ml" and ".cmo"
+files on the command line.
+
+Of course, you will always encounter this error if you have mutually
+recursive functions across modules. That is, function "Mod1.f" calls
+function "Mod2.g", and function "Mod2.g" calls function "Mod1.f".
+In this case, no matter what permutations you perform on the command
+line, the program will be rejected at link-time. Fixes:
+\begin{itemize}
+\item Put "f" and "g" in the same module.
+\item Parameterize one function by the other.
+That is, instead of having
+\begin{verbatim}
+mod1.ml: let f x = ... Mod2.g ...
+mod2.ml: let g y = ... Mod1.f ...
+\end{verbatim}
+define
+\begin{verbatim}
+mod1.ml: let f g x = ... g ...
+mod2.ml: let rec g y = ... Mod1.f g ...
+\end{verbatim}
+and link "mod1.cmo" before "mod2.cmo".
+\item Use a reference to hold one of the two functions, as in :
+\begin{verbatim}
+mod1.ml: let forward_g =
+ ref((fun x -> failwith "forward_g") : <type>)
+ let f x = ... !forward_g ...
+mod2.ml: let g y = ... Mod1.f ...
+ let _ = Mod1.forward_g := g
+\end{verbatim}
+\end{itemize}
+
+\item[The external function \var{f} is not available]
+This error appears when trying to link code that calls external
+functions written in C. As explained in
+chapter~\ref{c:intf-c}, such code must be linked with C libraries that
+implement the required \var{f} C function. If the C libraries in
+question are not shared libraries (DLLs), the code must be linked in
+``custom runtime'' mode. Fix: add the required C libraries to the
+command line, and possibly the "-custom" option.
+
+\end{options}
+
+\section{Warning reference} \label{s:comp-warnings}
+
+This section describes and explains in detail some warnings:
+
+\subsection{Warning 9: missing fields in a record pattern}
+
+ When pattern matching on records, it can be useful to match only few
+ fields of a record. Eliding fields can be done either implicitly
+ or explicitly by ending the record pattern with "; _".
+ However, implicit field elision is at odd with pattern matching
+ exhaustiveness checks.
+ Enabling warning 9 prioritizes exhaustiveness checks over the
+ convenience of implicit field elision and will warn on implicit
+ field elision in record patterns. In particular, this warning can
+ help to spot exhaustive record pattern that may need to be updated
+ after the addition of new fields to a record type.
+
+\begin{verbatim}
+type 'a point = {x='a ;y='a}
+let dx { x } = x (* implicit field elision: trigger warning 9 *)
+let dy { y; _ } = y (* explicit field elision: do not trigger warning 9 *)
+\end{verbatim}
+
+\subsection{Warning 52: fragile constant pattern}
+\label{ss:warn52}
+
+ Some constructors, such as the exception constructors "Failure" and
+ "Invalid_argument", take as parameter a "string" value holding
+ a text message intended for the user.
+
+ These text messages are usually not stable over time: call sites
+ building these constructors may refine the message in a future
+ version to make it more explicit, etc. Therefore, it is dangerous to
+ match over the precise value of the message. For example, until
+ OCaml 4.02, "Array.iter2" would raise the exception
+\begin{verbatim}
+ Invalid_argument "arrays must have the same length"
+\end{verbatim}
+ Since 4.03 it raises the more helpful message
+\begin{verbatim}
+ Invalid_argument "Array.iter2: arrays must have the same length"
+\end{verbatim}
+ but this means that any code of the form
+\begin{verbatim}
+ try ...
+ with Invalid_argument "arrays must have the same length" -> ...
+\end{verbatim}
+ is now broken and may suffer from uncaught exceptions.
+
+ Warning 52 is there to prevent users from writing such fragile code
+ in the first place. It does not occur on every matching on a literal
+ string, but only in the case in which library authors expressed
+ their intent to possibly change the constructor parameter value in
+ the future, by using the attribute "ocaml.warn_on_literal_pattern"
+ (see the manual section on builtin attributes in
+ \ref{ss:builtin-attributes}):
+\begin{verbatim}
+ type t =
+ | Foo of string [@ocaml.warn_on_literal_pattern]
+ | Bar of string
+
+ let no_warning = function
+ | Bar "specific value" -> 0
+ | _ -> 1
+
+ let warning = function
+ | Foo "specific value" -> 0
+ | _ -> 1
+
+> | Foo "specific value" -> 0
+> ^^^^^^^^^^^^^^^^
+> Warning 52: Code should not depend on the actual values of
+> this constructor's arguments. They are only for information
+> and may change in future versions. (See manual section 8.5)
+\end{verbatim}
+
+ In particular, all built-in exceptions with a string argument have
+ this attribute set: "Invalid_argument", "Failure", "Sys_error" will
+ all raise this warning if you match for a specific string argument.
+
+ If your code raises this warning, you should {\em not} change the
+ way you test for the specific string to avoid the warning (for
+ example using a string equality inside the right-hand-side instead
+ of a literal pattern), as your code would remain fragile. You should
+ instead enlarge the scope of the pattern by matching on all possible
+ values.
+
+\begin{verbatim}
+
+let warning = function
+ | Foo _ -> 0
+ | _ -> 1
+\end{verbatim}
+
+ This may require some care: if the scrutinee may return several
+ different cases of the same pattern, or raise distinct instances of
+ the same exception, you may need to modify your code to separate
+ those several cases.
+
+ For example,
+\begin{verbatim}
+try (int_of_string count_str, bool_of_string choice_str) with
+ | Failure "int_of_string" -> (0, true)
+ | Failure "bool_of_string" -> (-1, false)
+\end{verbatim}
+ should be rewritten into more atomic tests. For example,
+ using the "exception" patterns documented in Section~\ref{s:exception-match},
+ one can write:
+\begin{verbatim}
+match int_of_string count_str with
+ | exception (Failure _) -> (0, true)
+ | count ->
+ begin match bool_of_string choice_str with
+ | exception (Failure _) -> (-1, false)
+ | choice -> (count, choice)
+ end
+\end{verbatim}
+
+The only case where that transformation is not possible is if a given
+function call may raise distinct exceptions with the same constructor
+but different string values. In this case, you will have to check for
+specific string values. This is dangerous API design and it should be
+discouraged: it's better to define more precise exception constructors
+than store useful information in strings.
+
+\subsection{Warning 57: Ambiguous or-pattern variables under guard}
+\label{ss:warn57}
+
+ The semantics of or-patterns in OCaml is specified with
+ a left-to-right bias: a value \var{v} matches the pattern \var{p} "|" \var{q}
+ if it matches \var{p} or \var{q}, but if it matches both,
+ the environment captured by the match is the environment captured by
+ \var{p}, never the one captured by \var{q}.
+
+ While this property is generally intuitive, there is at least one specific
+ case where a different semantics might be expected.
+ Consider a pattern followed by a when-guard:
+ "|"~\var{p}~"when"~\var{g}~"->"~\var{e}, for example:
+\begin{verbatim}
+ | ((Const x, _) | (_, Const x)) when is_neutral x -> branch
+\end{verbatim}
+ The semantics is clear:
+ match the scrutinee against the pattern, if it matches, test the guard,
+ and if the guard passes, take the branch.
+ In particular, consider the input "(Const"~\var{a}", Const"~\var{b}")", where
+ \var{a} fails the test "is_neutral"~\var{a}, while \var{b} passes the test
+ "is_neutral"~\var{b}. With the left-to-right semantics, the clause above is
+ {\em not} taken by its input: matching "(Const"~\var{a}", Const"~\var{b}")"
+ against the or-pattern succeeds in the left branch, it returns the
+ environment \var{x}~"->"~\var{a}, and then the guard
+ "is_neutral"~\var{a} is tested and fails, the branch is not taken.
+
+ However, another semantics may be considered more natural here:
+ any pair that has one side passing the test will take the branch. With this
+ semantics the previous code fragment would be equivalent to
+\begin{verbatim}
+ | (Const x, _) when is_neutral x -> branch
+ | (_, Const x) when is_neutral x -> branch
+\end{verbatim}
+ This is {\em not} the semantics adopted by OCaml.
+
+ Warning 57 is dedicated to these confusing cases where the
+ specified left-to-right semantics is not equivalent to a non-deterministic
+ semantics (any branch can be taken) relatively to a specific guard.
+ More precisely, it warns when guard uses ``ambiguous'' variables, that are bound
+ to different parts of the scrutinees by different sides of a or-pattern.
--- /dev/null
+\chapter{The debugger (ocamldebug)} \label{c:debugger}
+\pdfchapter{The debugger (ocamldebug)}
+%HEVEA\cutname{debugger.html}
+
+This chapter describes the OCaml source-level replay debugger
+"ocamldebug".
+
+\begin{unix} The debugger is available on Unix systems that provide
+BSD sockets.
+\end{unix}
+
+\begin{windows} The debugger is available under the Cygwin port of
+OCaml, but not under the native Win32 ports.
+\end{windows}
+
+\section{Compiling for debugging}
+
+Before the debugger can be used, the program must be compiled and
+linked with the "-g" option: all ".cmo" and ".cma" files that are part
+of the program should have been created with "ocamlc -g", and they
+must be linked together with "ocamlc -g".
+
+Compiling with "-g" entails no penalty on the running time of
+programs: object files and bytecode executable files are bigger and
+take longer to produce, but the executable files run at
+exactly the same speed as if they had been compiled without "-g".
+
+\section{Invocation}
+
+\subsection{Starting the debugger}
+
+The OCaml debugger is invoked by running the program
+"ocamldebug" with the name of the bytecode executable file as first
+argument:
+\begin{alltt}
+ ocamldebug \optvar{options} \var{program} \optvar{arguments}
+\end{alltt}
+The arguments following \var{program} are optional, and are passed as
+command-line arguments to the program being debugged. (See also the
+"set arguments" command.)
+
+The following command-line options are recognized:
+\begin{options}
+\item["-c " \var{count}]
+Set the maximum number of simultaneously live checkpoints to \var{count}.
+
+\item["-cd " \var{dir}]
+Run the debugger program from the working directory \var{dir},
+instead of the current directory. (See also the "cd" command.)
+
+\item["-emacs"]
+Tell the debugger it is executed under Emacs. (See
+section~\ref{s:inf-debugger} for information on how to run the
+debugger under Emacs.)
+
+\item["-I "\var{directory}]
+Add \var{directory} to the list of directories searched for source
+files and compiled files. (See also the "directory" command.)
+
+\item["-s "\var{socket}]
+Use \var{socket} for communicating with the debugged program. See the
+description of the command "set socket" (section~\ref{s:communication})
+for the format of \var{socket}.
+
+\item["-version"]
+Print version string and exit.
+
+\item["-vnum"]
+Print short version number and exit.
+
+\item["-help" or "--help"]
+Display a short usage summary and exit.
+%
+\end{options}
+
+\subsection{Initialization file}
+
+On start-up, the debugger will read commands from an initialization
+file before giving control to the user. The default file is
+".ocamldebug" in the current directory if it exists, otherwise
+".ocamldebug" in the user's home directory.
+
+\subsection{Exiting the debugger}
+
+The command "quit" exits the debugger. You can also exit the debugger
+by typing an end-of-file character (usually "ctrl-D").
+
+Typing an interrupt character (usually "ctrl-C") will not exit the
+debugger, but will terminate the action of any debugger command that is in
+progress and return to the debugger command level.
+
+\section{Commands} \label{s:debugger-commands}
+
+A debugger command is a single line of input. It starts with a command
+name, which is followed by arguments depending on this name. Examples:
+\begin{verbatim}
+ run
+ goto 1000
+ set arguments arg1 arg2
+\end{verbatim}
+
+A command name can be truncated as long as there is no ambiguity. For
+instance, "go 1000" is understood as "goto 1000", since there are no
+other commands whose name starts with "go". For the most frequently
+used commands, ambiguous abbreviations are allowed. For instance, "r"
+stands for "run" even though there are others commands starting with
+"r". You can test the validity of an abbreviation using the "help" command.
+
+If the previous command has been successful, a blank line (typing just
+"RET") will repeat it.
+
+\subsection{Getting help}
+
+The OCaml debugger has a simple on-line help system, which gives
+a brief description of each command and variable.
+
+\begin{options}
+\item["help"]
+Print the list of commands.
+
+\item["help "\var{command}]
+Give help about the command \var{command}.
+
+\item["help set "\var{variable}, "help show "\var{variable}]
+Give help about the variable \var{variable}. The list of all debugger
+variables can be obtained with "help set".
+
+\item["help info "\var{topic}]
+Give help about \var{topic}. Use "help info" to get a list of known topics.
+\end{options}
+
+\subsection{Accessing the debugger state}
+
+\begin{options}
+\item["set "\var{variable} \var{value}]
+Set the debugger variable \var{variable} to the value \var{value}.
+
+\item["show "\var{variable}]
+Print the value of the debugger variable \var{variable}.
+
+\item["info "\var{subject}]
+Give information about the given subject.
+For instance, "info breakpoints" will print the list of all breakpoints.
+\end{options}
+
+\section{Executing a program}
+
+\subsection{Events}
+
+Events are ``interesting'' locations in the source code, corresponding
+to the beginning or end of evaluation of ``interesting''
+sub-expressions. Events are the unit of single-stepping (stepping goes
+to the next or previous event encountered in the program execution).
+Also, breakpoints can only be set at events. Thus, events play the
+role of line numbers in debuggers for conventional languages.
+
+During program execution, a counter is incremented at each event
+encountered. The value of this counter is referred as the {\em current
+time}. Thanks to reverse execution, it is possible to jump back and
+forth to any time of the execution.
+
+Here is where the debugger events (written \event) are located in
+the source code:
+\begin{itemize}
+\item Following a function application:
+\begin{alltt}
+(f arg)\event
+\end{alltt}
+\item On entrance to a function:
+\begin{alltt}
+fun x y z -> \event ...
+\end{alltt}
+\item On each case of a pattern-matching definition (function,
+"match"\ldots"with" construct, "try"\ldots"with" construct):
+\begin{alltt}
+function pat1 -> \event expr1
+ | ...
+ | patN -> \event exprN
+\end{alltt}
+\item Between subexpressions of a sequence:
+\begin{alltt}
+expr1; \event expr2; \event ...; \event exprN
+\end{alltt}
+\item In the two branches of a conditional expression:
+\begin{alltt}
+if cond then \event expr1 else \event expr2
+\end{alltt}
+\item At the beginning of each iteration of a loop:
+\begin{alltt}
+while cond do \event body done
+for i = a to b do \event body done
+\end{alltt}
+\end{itemize}
+Exceptions: A function application followed by a function return is replaced
+by the compiler by a jump (tail-call optimization). In this case, no
+event is put after the function application.
+% Also, no event is put after a function application when the function
+% is external (written in C).
+
+\subsection{Starting the debugged program}
+
+The debugger starts executing the debugged program only when needed.
+This allows setting breakpoints or assigning debugger variables before
+execution starts. There are several ways to start execution:
+\begin{options}
+\item["run"] Run the program until a breakpoint is hit, or the program
+terminates.
+\item["goto 0"] Load the program and stop on the first event.
+\item["goto "\var{time}] Load the program and execute it until the
+given time. Useful when you already know approximately at what time
+the problem appears. Also useful to set breakpoints on function values
+that have not been computed at time 0 (see section~\ref{s:breakpoints}).
+\end{options}
+
+The execution of a program is affected by certain information it
+receives when the debugger starts it, such as the command-line
+arguments to the program and its working directory. The debugger
+provides commands to specify this information ("set arguments" and "cd").
+These commands must be used before program execution starts. If you try
+to change the arguments or the working directory after starting your
+program, the debugger will kill the program (after asking for confirmation).
+
+\subsection{Running the program}
+
+The following commands execute the program forward or backward,
+starting at the current time. The execution will stop either when
+specified by the command or when a breakpoint is encountered.
+
+\begin{options}
+\item["run"] Execute the program forward from current time. Stops at
+next breakpoint or when the program terminates.
+\item["reverse"] Execute the program backward from current time.
+Mostly useful to go to the last breakpoint encountered before the
+current time.
+\item["step "\optvar{count}] Run the program and stop at the next
+event. With an argument, do it \var{count} times. If \var{count} is 0,
+run until the program terminates or a breakpoint is hit.
+\item["backstep "\optvar{count}] Run the program backward and stop at
+the previous event. With an argument, do it \var{count} times.
+\item["next "\optvar{count}] Run the program and stop at the next
+event, skipping over function calls. With an argument, do it
+\var{count} times.
+\item["previous "\optvar{count}] Run the program backward and stop at
+the previous event, skipping over function calls. With an argument, do
+it \var{count} times.
+\item["finish"] Run the program until the current function returns.
+\item["start"] Run the program backward and stop at the first event
+before the current function invocation.
+\end{options}
+
+\subsection{Time travel}
+
+You can jump directly to a given time, without stopping on
+breakpoints, using the "goto" command.
+
+As you move through the program, the debugger maintains an history of
+the successive times you stop at. The "last" command can be used to
+revisit these times: each "last" command moves one step back through
+the history. That is useful mainly to undo commands such as "step"
+and "next".
+
+\begin{options}
+\item["goto "\var{time}]
+Jump to the given time.
+\item["last "\optvar{count}]
+Go back to the latest time recorded in the execution history. With an
+argument, do it \var{count} times.
+\item["set history "\var{size}]
+Set the size of the execution history.
+\end{options}
+
+\subsection{Killing the program}
+
+\begin{options}
+\item["kill"] Kill the program being executed. This command is mainly
+useful if you wish to recompile the program without leaving the debugger.
+\end{options}
+
+\section{Breakpoints} \label{s:breakpoints}
+
+A breakpoint causes the program to stop whenever a certain point in
+the program is reached. It can be set in several ways using the
+"break" command. Breakpoints are assigned numbers when set, for
+further reference. The most comfortable way to set breakpoints is
+through the Emacs interface (see section~\ref{s:inf-debugger}).
+
+\begin{options}
+\item["break"]
+Set a breakpoint at the current position in the program execution. The
+current position must be on an event (i.e., neither at the beginning,
+nor at the end of the program).
+
+\item["break "\var{function}]
+Set a breakpoint at the beginning of \var{function}. This works only
+when the functional value of the identifier \var{function} has been
+computed and assigned to the identifier. Hence this command cannot be
+used at the very beginning of the program execution, when all
+identifiers are still undefined; use "goto" \var{time} to advance
+execution until the functional value is available.
+
+\item["break \@" \optvar{module} \var{line}]
+Set a breakpoint in module \var{module} (or in the current module if
+\var{module} is not given), at the first event of line \var{line}.
+
+\item["break \@" \optvar{module} \var{line} \var{column}]
+Set a breakpoint in module \var{module} (or in the current module if
+\var{module} is not given), at the event closest to line \var{line},
+column \var{column}.
+
+\item["break \@" \optvar{module} "#" \var{character}]
+Set a breakpoint in module \var{module} at the event closest to
+character number \var{character}.
+
+\item["break "\var{address}]
+Set a breakpoint at the code address \var{address}.
+
+\item["delete "\optvar{breakpoint-numbers}]
+Delete the specified breakpoints. Without argument, all breakpoints
+are deleted (after asking for confirmation).
+
+\item["info breakpoints"] Print the list of all breakpoints.
+\end{options}
+
+\section{The call stack}
+
+Each time the program performs a function application, it saves the
+location of the application (the return address) in a block of data
+called a stack frame. The frame also contains the local variables of
+the caller function. All the frames are allocated in a region of
+memory called the call stack. The command "backtrace" (or "bt")
+displays parts of the call stack.
+
+At any time, one of the stack frames is ``selected'' by the debugger; several
+debugger commands refer implicitly to the selected frame. In particular,
+whenever you ask the debugger for the value of a local variable, the
+value is found in the selected frame. The commands "frame", "up" and "down"
+select whichever frame you are interested in.
+
+When the program stops, the debugger automatically selects the
+currently executing frame and describes it briefly as the "frame"
+command does.
+
+\begin{options}
+\item["frame"]
+Describe the currently selected stack frame.
+
+\item["frame" \var{frame-number}]
+Select a stack frame by number and describe it. The frame currently
+executing when the program stopped has number 0; its caller has number
+1; and so on up the call stack.
+
+\item["backtrace "\optvar{count}, "bt "\optvar{count}]
+Print the call stack. This is useful to see which sequence of function
+calls led to the currently executing frame. With a positive argument,
+print only the innermost \var{count} frames.
+With a negative argument, print only the outermost -\var{count} frames.
+
+\item["up" \optvar{count}]
+Select and display the stack frame just ``above'' the selected frame,
+that is, the frame that called the selected frame. An argument says how
+many frames to go up.
+
+\item["down "\optvar{count}]
+Select and display the stack frame just ``below'' the selected frame,
+that is, the frame that was called by the selected frame. An argument
+says how many frames to go down.
+\end{options}
+
+\section{Examining variable values}
+
+The debugger can print the current value of simple expressions. The
+expressions can involve program variables: all the identifiers that
+are in scope at the selected program point can be accessed.
+
+Expressions that can be printed are a subset of OCaml
+expressions, as described by the following grammar:
+\begin{syntax}
+simple-expr:
+ lowercase-ident
+ | { capitalized-ident '.' } lowercase-ident
+ | '*'
+ | '$' integer
+ | simple-expr '.' lowercase-ident
+ | simple-expr '.(' integer ')'
+ | simple-expr '.[' integer ']'
+ | '!' simple-expr
+ | '(' simple-expr ')'
+\end{syntax}
+The first two cases refer to a value identifier, either unqualified or
+qualified by the path to the structure that define it.
+"*" refers to the result just computed (typically, the value of a
+function application), and is valid only if the selected event is an
+``after'' event (typically, a function application).
+@'$' integer@ refer to a previously printed value. The remaining four
+forms select part of an expression: respectively, a record field, an
+array element, a string element, and the current contents of a
+reference.
+
+\begin{options}
+\item["print "\var{variables}]
+Print the values of the given variables. "print" can be abbreviated as
+"p".
+\item["display "\var{variables}]
+Same as "print", but limit the depth of printing to 1. Useful to
+browse large data structures without printing them in full.
+"display" can be abbreviated as "d".
+\end{options}
+
+When printing a complex expression, a name of the form "$"\var{integer}
+is automatically assigned to its value. Such names are also assigned
+to parts of the value that cannot be printed because the maximal
+printing depth is exceeded. Named values can be printed later on
+with the commands "p $"\var{integer} or "d $"\var{integer}.
+Named values are valid only as long as the program is stopped. They
+are forgotten as soon as the program resumes execution.
+
+\begin{options}
+\item["set print_depth" \var{d}]
+Limit the printing of values to a maximal depth of \var{d}.
+\item["set print_length" \var{l}]
+Limit the printing of values to at most \var{l} nodes printed.
+\end{options}
+
+\section{Controlling the debugger}
+
+\subsection{Setting the program name and arguments}
+
+\begin{options}
+\item["set program" \var{file}]
+Set the program name to \var{file}.
+\item["set arguments" \var{arguments}]
+Give \var{arguments} as command-line arguments for the program.
+\end{options}
+
+A shell is used to pass the arguments to the debugged program. You can
+therefore use wildcards, shell variables, and file redirections inside
+the arguments. To debug programs that read from standard input, it is
+recommended to redirect their input from a file (using
+"set arguments < input-file"), otherwise input to the program and
+input to the debugger are not properly separated, and inputs are not
+properly replayed when running the program backwards.
+
+\subsection{How programs are loaded}
+
+The "loadingmode" variable controls how the program is executed.
+
+\begin{options}
+\item["set loadingmode direct"]
+The program is run directly by the debugger. This is the default mode.
+\item["set loadingmode runtime"]
+The debugger execute the OCaml runtime "ocamlrun" on the program.
+Rarely useful; moreover it prevents the debugging of programs compiled
+in ``custom runtime'' mode.
+\item["set loadingmode manual"]
+The user starts manually the program, when asked by the debugger.
+Allows remote debugging (see section~\ref{s:communication}).
+\end{options}
+
+\subsection{Search path for files}
+
+The debugger searches for source files and compiled interface files in
+a list of directories, the search path. The search path initially
+contains the current directory "." and the standard library directory.
+The "directory" command adds directories to the path.
+
+Whenever the search path is modified, the debugger will clear any
+information it may have cached about the files.
+
+\begin{options}
+\item["directory" \var{directorynames}]
+Add the given directories to the search path. These directories are
+added at the front, and will therefore be searched first.
+
+\item["directory" \var{directorynames} "for" \var{modulename}]
+Same as "directory" \var{directorynames}, but the given directories will be
+searched only when looking for the source file of a module that has
+been packed into \var{modulename}.
+
+\item["directory"]
+Reset the search path. This requires confirmation.
+\end{options}
+
+\subsection{Working directory}
+
+Each time a program is started in the debugger, it inherits its working
+directory from the current working directory of the debugger. This
+working directory is initially whatever it inherited from its parent
+process (typically the shell), but you can specify a new working
+directory in the debugger with the "cd" command or the "-cd"
+command-line option.
+
+\begin{options}
+\item["cd" \var{directory}]
+Set the working directory for "ocamldebug" to \var{directory}.
+
+\item["pwd"]
+Print the working directory for "ocamldebug".
+\end{options}
+
+\subsection{Turning reverse execution on and off}
+
+In some cases, you may want to turn reverse execution off. This speeds
+up the program execution, and is also sometimes useful for interactive
+programs.
+
+Normally, the debugger takes checkpoints of the program state from
+time to time. That is, it makes a copy of the current state of the
+program (using the Unix system call "fork"). If the variable
+\var{checkpoints} is set to "off", the debugger will not take any
+checkpoints.
+
+\begin{options}
+\item["set checkpoints" \var{on/off}]
+Select whether the debugger makes checkpoints or not.
+\end{options}
+
+\subsection{Communication between the debugger and the program}
+\label{s:communication}
+
+The debugger communicate with the program being debugged through a
+Unix socket. You may need to change the socket name, for example if
+you need to run the debugger on a machine and your program on another.
+
+\begin{options}
+\item["set socket" \var{socket}]
+Use \var{socket} for communication with the program. \var{socket} can be
+either a file name, or an Internet port specification
+\var{host}:\var{port}, where \var{host} is a host name or an Internet
+address in dot notation, and \var{port} is a port number on the host.
+\end{options}
+
+On the debugged program side, the socket name is passed through the
+"CAML_DEBUG_SOCKET" environment variable.
+
+\subsection{Fine-tuning the debugger} \label{s:fine-tuning}
+
+Several variables enables to fine-tune the debugger. Reasonable
+defaults are provided, and you should normally not have to change them.
+
+\begin{options}
+\item["set processcount" \var{count}]
+Set the maximum number of checkpoints to \var{count}. More checkpoints
+facilitate going far back in time, but use more memory and create more
+Unix processes.
+\end{options}
+
+As checkpointing is quite expensive, it must not be done too often. On
+the other hand, backward execution is faster when checkpoints are
+taken more often. In particular, backward single-stepping is more
+responsive when many checkpoints have been taken just before the
+current time. To fine-tune the checkpointing strategy, the debugger
+does not take checkpoints at the same frequency for long displacements
+(e.g. "run") and small ones (e.g. "step"). The two variables "bigstep"
+and "smallstep" contain the number of events between two checkpoints
+in each case.
+
+\begin{options}
+\item["set bigstep" \var{count}]
+Set the number of events between two checkpoints for long displacements.
+\item["set smallstep" \var{count}]
+Set the number of events between two checkpoints for small
+displacements.
+\end{options}
+
+The following commands display information on checkpoints and events:
+
+\begin{options}
+\item["info checkpoints"]
+Print a list of checkpoints.
+\item["info events" \optvar{module}]
+Print the list of events in the given module (the current module, by default).
+\end{options}
+
+\subsection{User-defined printers}
+
+Just as in the toplevel system (section~\ref{s:toplevel-directives}),
+the user can register functions for printing values of certain types.
+For technical reasons, the debugger cannot call printing functions
+that reside in the program being debugged. The code for the printing
+functions must therefore be loaded explicitly in the debugger.
+
+\begin{options}
+\item["load_printer \""\var{file-name}"\""]
+Load in the debugger the indicated ".cmo" or ".cma" object file. The
+file is loaded in an environment consisting only of the OCaml
+standard library plus the definitions provided by object files
+previously loaded using "load_printer". If this file depends on other
+object files not yet loaded, the debugger automatically loads them if
+it is able to find them in the search path. The loaded file does not
+have direct access to the modules of the program being debugged.
+
+\item["install_printer "\var{printer-name}]
+Register the function named \var{printer-name} (a
+value path) as a printer for objects whose types match the argument
+type of the function. That is, the debugger will call
+\var{printer-name} when it has such an object to print.
+The printing function \var{printer-name} must use the "Format" library
+module to produce its output, otherwise its output will not be
+correctly located in the values printed by the toplevel loop.
+
+The value path \var{printer-name} must refer to one of the functions
+defined by the object files loaded using "load_printer". It cannot
+reference the functions of the program being debugged.
+
+\item["remove_printer "\var{printer-name}]
+Remove the named function from the table of value printers.
+\end{options}
+
+\section{Miscellaneous commands}
+
+\begin{options}
+\item["list" \optvar{module} \optvar{beginning} \optvar{end}]
+List the source of module \var{module}, from line number
+\var{beginning} to line number \var{end}. By default, 20 lines of the
+current module are displayed, starting 10 lines before the current
+position.
+\item["source" \var{filename}]
+Read debugger commands from the script \var{filename}.
+\end{options}
+
+\section{Running the debugger under Emacs} \label{s:inf-debugger}
+
+The most user-friendly way to use the debugger is to run it under Emacs.
+See the file "emacs/README" in the distribution for information on how
+to load the Emacs Lisp files for OCaml support.
+
+The OCaml debugger is started under Emacs by the command "M-x
+camldebug", with argument the name of the executable file
+\var{progname} to debug. Communication with the debugger takes place
+in an Emacs buffer named "*camldebug-"\var{progname}"*". The editing
+and history facilities of Shell mode are available for interacting
+with the debugger.
+
+In addition, Emacs displays the source files containing the current
+event (the current position in the program execution) and highlights
+the location of the event. This display is updated synchronously with
+the debugger action.
+
+The following bindings for the most common debugger commands are
+available in the "*camldebug-"\var{progname}"*" buffer:
+
+\begin{options}
+\item["C-c C-s"] (command "step"): execute the program one step forward.
+\item["C-c C-k"] (command "backstep"): execute the program one step backward.
+\item["C-c C-n"] (command "next"): execute the program one step
+forward, skipping over function calls.
+\item[Middle mouse button] (command "display"): display named value.
+"$"\var{n} under mouse cursor (support incremental browsing of large
+data structures).
+\item["C-c C-p"] (command "print"): print value of identifier at point.
+\item["C-c C-d"] (command "display"): display value of identifier at point.
+\item["C-c C-r"] (command "run"): execute the program forward to next
+breakpoint.
+\item["C-c C-v"] (command "reverse"): execute the program backward to
+latest breakpoint.
+\item["C-c C-l"] (command "last"): go back one step in the command history.
+\item["C-c C-t"] (command "backtrace"): display backtrace of function calls.
+\item["C-c C-f"] (command "finish"): run forward till the current
+function returns.
+\item["C-c <"] (command "up"): select the stack frame below the
+current frame.
+\item["C-c >"] (command "down"): select the stack frame above the
+current frame.
+\end{options}
+
+In all buffers in OCaml editing mode, the following debugger commands
+are also available:
+
+\begin{options}
+\item["C-x C-a C-b"] (command "break"): set a breakpoint at event closest
+to point
+\item["C-x C-a C-p"] (command "print"): print value of identifier at point
+\item["C-x C-a C-d"] (command "display"): display value of identifier at point
+\end{options}
--- /dev/null
+\chapter{Dependency generator (ocamldep)} \label{c:camldep}
+\pdfchapter{Dependency generator (ocamldep)}
+%HEVEA\cutname{depend.html}
+
+The "ocamldep" command scans a set of OCaml source files
+(".ml" and ".mli" files) for references to external compilation units,
+and outputs dependency lines in a format suitable for the "make"
+utility. This ensures that "make" will compile the source files in the
+correct order, and recompile those files that need to when a source
+file is modified.
+
+The typical usage is:
+\begin{alltt}
+ ocamldep \var{options} *.mli *.ml > .depend
+\end{alltt}
+where "*.mli *.ml" expands to all source files in the current
+directory and ".depend" is the file that should contain the
+dependencies. (See below for a typical "Makefile".)
+
+Dependencies are generated both for compiling with the bytecode
+compiler "ocamlc" and with the native-code compiler "ocamlopt".
+
+\section{Options}
+
+The following command-line options are recognized by "ocamldep".
+
+\begin{options}
+
+\item["-absname"]
+Show absolute filenames in error messages.
+
+\item["-all"]
+Generate dependencies on all required files, rather than assuming
+implicit dependencies.
+
+\item["-allow-approx"]
+Allow falling back on a lexer-based approximation when parsing fails.
+
+\item["-args" \var{filename}]
+ Read additional newline-terminated command line arguments from \var{filename}.
+
+\item["-args0" \var{filename}]
+ Read additional null character terminated command line arguments from \var{filename}.
+
+\item["-as-map"]
+For the following files, do not include delayed dependencies for
+module aliases.
+This option assumes that they are compiled using options
+"-no-alias-deps -w -49", and that those files or their interface are
+passed with the "-map" option when computing dependencies for other
+files. Note also that for dependencies to be correct in the
+implementation of a map file, its interface should not coerce any of
+the aliases it contains.
+
+\item["-debug-map"]
+Dump the delayed dependency map for each map file.
+
+\item["-I" \var{directory}]
+Add the given directory to the list of directories searched for
+source files. If a source file "foo.ml" mentions an external
+compilation unit "Bar", a dependency on that unit's interface
+"bar.cmi" is generated only if the source for "bar" is found in the
+current directory or in one of the directories specified with "-I".
+Otherwise, "Bar" is assumed to be a module from the standard library,
+and no dependencies are generated. For programs that span multiple
+directories, it is recommended to pass "ocamldep" the same "-I" options
+that are passed to the compiler.
+
+\item["-impl" \var{file}]
+Process \var{file} as a ".ml" file.
+
+\item["-intf" \var{file}]
+Process \var{file} as a ".mli" file.
+
+\item["-map" \var{file}]
+Read an propagate the delayed dependencies for module aliases in
+\var{file}, so that the following files will depend on the
+exported aliased modules if they use them. See the example below.
+
+\item["-ml-synonym" \var{.ext}]
+Consider the given extension (with leading dot) to be a synonym for .ml.
+
+\item["-mli-synonym" \var{.ext}]
+Consider the given extension (with leading dot) to be a synonym for .mli.
+
+\item["-modules"]
+Output raw dependencies of the form
+\begin{verbatim}
+ filename: Module1 Module2 ... ModuleN
+\end{verbatim}
+where "Module1", \ldots, "ModuleN" are the names of the compilation
+units referenced within the file "filename", but these names are not
+resolved to source file names. Such raw dependencies cannot be used
+by "make", but can be post-processed by other tools such as "Omake".
+
+\item["-native"]
+Generate dependencies for a pure native-code program (no bytecode
+version). When an implementation file (".ml" file) has no explicit
+interface file (".mli" file), "ocamldep" generates dependencies on the
+bytecode compiled file (".cmo" file) to reflect interface changes.
+This can cause unnecessary bytecode recompilations for programs that
+are compiled to native-code only. The flag "-native" causes
+dependencies on native compiled files (".cmx") to be generated instead
+of on ".cmo" files. (This flag makes no difference if all source files
+have explicit ".mli" interface files.)
+
+\item["-one-line"]
+Output one line per file, regardless of the length.
+
+\item["-open" \var{module}]
+Assume that module \var{module} is opened before parsing each of the
+following files.
+
+\item["-plugin" \var{plugin}]
+Dynamically load the code of the given \var{plugin}
+(a ".cmo", ".cma" or ".cmxs" file) in "ocamldep". \var{plugin} must exist in
+the same kind of code as "ocamldep" ("ocamldep.byte" must load bytecode
+plugins, while "ocamldep.opt" must load native code plugins), and
+extension adaptation is done automatically for ".cma" files (to ".cmxs" files
+if "ocamldep" is compiled in native code).
+
+\item["-pp" \var{command}]
+Cause "ocamldep" to call the given \var{command} as a preprocessor
+for each source file.
+
+\item["-ppx" \var{command}]
+Pipe abstract syntax trees through preprocessor \var{command}.
+
+\item["-shared"]
+Generate dependencies for native plugin files (.cmxs) in addition to
+native compiled files (.cmx).
+
+\item["-slash"]
+Under Windows, use a forward slash (/) as the path separator instead
+of the usual backward slash ($\backslash$). Under Unix, this option does
+nothing.
+
+\item["-sort"]
+Sort files according to their dependencies.
+
+\item["-version"]
+Print version string and exit.
+
+\item["-vnum"]
+Print short version number and exit.
+
+\item["-help" or "--help"]
+Display a short usage summary and exit.
+%
+\end{options}
+
+\section{A typical Makefile}
+
+Here is a template "Makefile" for a OCaml program.
+
+\begin{verbatim}
+OCAMLC=ocamlc
+OCAMLOPT=ocamlopt
+OCAMLDEP=ocamldep
+INCLUDES= # all relevant -I options here
+OCAMLFLAGS=$(INCLUDES) # add other options for ocamlc here
+OCAMLOPTFLAGS=$(INCLUDES) # add other options for ocamlopt here
+
+# prog1 should be compiled to bytecode, and is composed of three
+# units: mod1, mod2 and mod3.
+
+# The list of object files for prog1
+PROG1_OBJS=mod1.cmo mod2.cmo mod3.cmo
+
+prog1: $(PROG1_OBJS)
+ $(OCAMLC) -o prog1 $(OCAMLFLAGS) $(PROG1_OBJS)
+
+# prog2 should be compiled to native-code, and is composed of two
+# units: mod4 and mod5.
+
+# The list of object files for prog2
+PROG2_OBJS=mod4.cmx mod5.cmx
+
+prog2: $(PROG2_OBJS)
+ $(OCAMLOPT) -o prog2 $(OCAMLFLAGS) $(PROG2_OBJS)
+
+# Common rules
+.SUFFIXES: .ml .mli .cmo .cmi .cmx
+
+.ml.cmo:
+ $(OCAMLC) $(OCAMLFLAGS) -c $<
+
+.mli.cmi:
+ $(OCAMLC) $(OCAMLFLAGS) -c $<
+
+.ml.cmx:
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c $<
+
+# Clean up
+clean:
+ rm -f prog1 prog2
+ rm -f *.cm[iox]
+
+# Dependencies
+depend:
+ $(OCAMLDEP) $(INCLUDES) *.mli *.ml > .depend
+
+include .depend
+\end{verbatim}
+
+If you use module aliases to give shorter names to modules, you need
+to change the above definitions. Assuming that your map file is called
+"mylib.mli", here are minimal modifications.
+\begin{verbatim}
+OCAMLFLAGS=$(INCLUDES) -open Mylib
+
+mylib.cmi: mylib.mli
+ $(OCAMLC) $(INCLUDES) -no-alias-deps -w -49 -c $<
+
+depend:
+ $(OCAMLDEP) $(INCLUDES) -map mylib.mli $(PROG1_OBJS:.cmo=.ml) > .depend
+\end{verbatim}
+Note that in this case you should not compute dependencies for
+"mylib.mli" together with the other files, hence the need to pass
+explicitly the list of files to process.
+If "mylib.mli" itself has dependencies, you should compute them using
+"-as-map".
--- /dev/null
+\chapter{Optimisation with Flambda}
+\pdfchapterfold{-9}{Optimisation with Flambda}
+%HEVEA\cutname{flambda.html}
+
+\section{Overview}
+
+{\em Flambda} is the term used to describe a series of optimisation passes
+provided by the native code compilers as of OCaml 4.03.
+
+Flambda aims to make it easier to write idiomatic OCaml code without
+incurring performance penalties.
+
+To use the Flambda optimisers it is necessary to pass the {\tt -flambda}
+option to the OCaml {\tt configure} script. (There is no support for a
+single compiler that can operate in both Flambda and non-Flambda modes.)
+Code compiled with Flambda
+cannot be linked into the same program as code compiled without Flambda.
+Attempting to do this will result in a compiler error.
+
+Whether or not a particular {\tt ocamlopt} uses Flambda may be
+determined by invoking it with the {\tt -config} option and looking
+for any line starting with ``{\tt flambda:}''. If such a line is present
+and says ``{\tt true}'', then Flambda is supported, otherwise it is not.
+
+Flambda provides full optimisation across different compilation units,
+so long as the {\tt .cmx} files for the dependencies of the unit currently
+being compiled are available. (A compilation unit corresponds to a
+single {\tt .ml} source file.) However it does not yet act entirely as
+a whole-program compiler: for example, elimination of dead code across
+a complete set of compilation units is not supported.
+
+Optimisation with Flambda is not currently supported when generating
+bytecode.
+
+Flambda should not in general affect the semantics of existing programs.
+Two exceptions to this rule are: possible elimination of pure code
+that is being benchmarked (see section\ \ref{inhibition}) and changes in
+behaviour of code using unsafe operations (see section\ \ref{unsafe}).
+
+Flambda does not yet optimise array or string bounds checks. Neither
+does it take hints for optimisation from any assertions written by the
+user in the code.
+
+Consult the {\em Glossary} at the end of this chapter for definitions of
+technical terms used below.
+
+\section{Command-line flags}
+
+The Flambda optimisers provide a variety of command-line flags that may
+be used to control their behaviour. Detailed descriptions of each flag
+are given in the referenced sections. Those sections also describe any
+arguments which the particular flags take.
+
+Commonly-used options:
+\begin{options}
+\item[\machine{-O2}] Perform more optimisation than usual. Compilation
+times may be lengthened. (This flag is an abbreviation for a certain
+set of parameters described in section\ \ref{defaults}.)
+\item[\machine{-O3}] Perform even more optimisation than usual, possibly
+including unrolling of recursive functions. Compilation times may be
+significantly lengthened.
+\item[\machine{-Oclassic}] Make inlining decisions at the point of
+definition of a function rather than at the call site(s). This mirrors
+the behaviour of OCaml compilers not using Flambda. Compared to compilation
+using the new Flambda inlining heuristics (for example at {\tt -O2}) it
+produces
+smaller {\tt .cmx} files, shorter compilation times and code that probably
+runs rather slower. When using {\tt -Oclassic}, only the following options
+described in this section are relevant: {\tt -inlining-report} and
+{\tt -inline}. If any other of the options described in this section are
+used, the behaviour is undefined and may cause an error in future versions
+of the compiler.
+\item[\machine{-inlining-report}] Emit {\tt .inlining} files (one per
+round of optimisation) showing all of the inliner's decisions.
+\end{options}
+
+Less commonly-used options:
+\begin{options}
+\item[\machine{-remove-unused-arguments}] Remove unused function arguments
+even when the argument is not specialised. This may have a small
+performance penalty.
+See section\ \ref{remove-unused-args}.
+\item[\machine{-unbox-closures}] Pass free variables via specialised arguments
+rather than closures (an optimisation for reducing allocation). See
+section\ \ref{unbox-closures}. This may have a small performance penalty.
+\end{options}
+
+Advanced options, only needed for detailed tuning:
+\begin{options}
+\item[\machine{-inline}] The behaviour depends on whether {\tt -Oclassic}
+is used.
+\begin{itemize}
+\item When not in {\tt -Oclassic} mode, {\tt -inline} limits the total
+size of functions considered for inlining during any speculative inlining
+search. (See section\ \ref{speculation}.) Note that
+this parameter does
+{\bf not} control the assessment as to whether any particular function may
+be inlined. Raising it to excessive amounts will not necessarily cause
+more functions to be inlined.
+\item When in {\tt -Oclassic} mode, {\tt -inline} behaves as in
+previous versions of the compiler: it is the maximum size of function to
+be considered for inlining. See section\ \ref{classic}.
+\end{itemize}
+\item[\machine{-inline-toplevel}] The equivalent of {\tt -inline} but used
+when speculative inlining starts at toplevel. See
+section\ \ref{speculation}.
+Not used in {\tt -Oclassic} mode.
+\item[\machine{-inline-branch-factor}] Controls how the inliner assesses
+whether a code path is likely to be hot or cold. See
+section\ \ref{assessment-inlining}.
+\item[\machine{-inline-alloc-cost},
+ \machine{-inline-branch-cost},
+ \machine{-inline-call-cost}] Controls how the inliner assesses the runtime
+ performance penalties associated with various operations. See
+ section\ \ref{assessment-inlining}.
+\item[\machine{-inline-indirect-cost},
+ \machine{-inline-prim-cost}] Likewise.
+\item[\machine{-inline-lifting-benefit}] Controls inlining of functors
+at toplevel. See section\ \ref{assessment-inlining}.
+\item[\machine{-inline-max-depth}] The maximum depth of any
+speculative inlining search. See section\ \ref{speculation}.
+\item[\machine{-inline-max-unroll}] The maximum depth of any unrolling of
+recursive functions during any speculative inlining search.
+See section\ \ref{speculation}.
+\item[\machine{-no-unbox-free-vars-of-closures}] %
+Do not unbox closure variables. See section\ \ref{unbox-fvs}.
+\item[\machine{-no-unbox-specialised-args}] %
+Do not unbox arguments to which functions have been specialised. See
+section\ \ref{unbox-spec-args}.
+\item[\machine{-rounds}] How many rounds of optimisation to perform.
+See section\ \ref{rounds}.
+\item[\machine{-unbox-closures-factor}] Scaling factor for benefit
+calculation when using {\tt -unbox-closures}. See
+section\ \ref{unbox-closures}.
+\end{options}
+
+\paragraph{Notes}
+\begin{itemize}
+\item The set of command line flags relating to optimisation should typically
+be specified to be the same across an entire project. Flambda does not
+currently record the requested flags in the {\tt .cmx} files. As such,
+inlining of functions from previously-compiled units will subject their code
+to the optimisation parameters of the unit currently being compiled, rather
+than those specified when they were previously compiled. It is hoped to
+rectify this deficiency in the future.
+
+\item Flambda-specific flags do not affect linking with the exception of
+affecting the optimisation of code in the startup file (containing
+generated functions such as currying helpers). Typically such optimisation
+will not be significant, so eliding such flags at link time might be
+reasonable.
+
+\item Flambda-specific flags are silently accepted even when the
+{\tt -flambda} option was not provided to the {\tt configure} script.
+(There is no means provided to change this behaviour.)
+This is intended to make it more
+straightforward to run benchmarks with and without the Flambda optimisers
+in effect.
+\item Some of the Flambda flags may be subject to change in future
+releases.
+\end{itemize}
+
+\subsection{Specification of optimisation parameters by round}\label{rounds}
+
+Flambda operates in {\em rounds}: one round consists of a certain sequence
+of transformations that may then be repeated in order to achieve more
+satisfactory results. The number of rounds can be set manually using the
+{\tt -rounds} parameter (although this is not necessary when using
+predefined optimisation levels such as with {\tt -O2} and {\tt -O3}).
+For high optimisation the number of rounds might be set at 3 or 4.
+
+Command-line flags that may apply per round, for example those with
+{\tt "-cost"} in the name, accept arguments of the form:
+\begin{center}
+{\em n}{\tt\ |\ }{\em round}{\tt =}{\em n}[{\tt,}...]
+\end{center}
+\begin{itemize}
+\item If the first form is used, with a single integer specified,
+the value will apply to all rounds.
+\item If the second form is used, zero-based {\em round} integers specify
+values which are to be used only for those rounds.
+\end{itemize}
+
+The flags {\tt -Oclassic}, {\tt -O2} and {\tt -O3} are applied before all
+other flags, meaning that certain parameters may be overridden without
+having to specify every parameter usually invoked by the given optimisation
+level.
+
+\section{Inlining}
+
+{\em Inlining} refers to the copying of the code of a function to a
+place where the function is called.
+The code of the function will be surrounded by bindings of its parameters
+to the corresponding arguments.
+
+The aims of inlining are:
+\begin{itemize}
+\item to reduce the runtime overhead caused by function calls (including
+setting up for such calls and returning afterwards);
+\item to reduce instruction cache misses by expressing frequently-taken
+paths through the program using fewer machine instructions; and
+\item to reduce the amount of allocation (especially of closures).
+\end{itemize}
+These goals are often reached not just by inlining itself but also by
+other optimisations that the compiler is able to perform as a result of
+inlining.
+
+When a recursive call to a function (within the definition of that function
+or another in the same mutually-recursive group) is inlined, the procedure is
+also known as {\em unrolling}. This is somewhat akin to loop peeling.
+For example, given the following code:
+\begin{verbatim}
+let rec fact x =
+ if x = 0 then
+ 1
+ else
+ x * fact (x - 1)
+
+let n = fact 4
+\end{verbatim}
+unrolling once at the call site {\tt fact 4} produces (with the body of
+{\tt fact} unchanged):
+\begin{verbatim}
+let n =
+ if 4 = 0 then
+ 1
+ else
+ 4 * fact (4 - 1)
+\end{verbatim}
+This simplifies to:
+\begin{verbatim}
+let n = 4 * fact 3
+\end{verbatim}
+
+%% CR pchambart: A specific section for unrolling might be worth (telling
+%% when this is beneficial)
+
+Flambda provides significantly enhanced inlining capabilities relative to
+previous versions of the compiler.
+
+\subsubsection{Aside: when inlining is performed}
+
+Inlining is performed together with all of the other Flambda optimisation
+passes, that is to say, after closure conversion. This has three particular
+advantages over a potentially more straightforward implementation prior to
+closure conversion:
+\begin{itemize}
+\item It permits higher-order inlining, for example when a non-inlinable
+function always returns the same function yet with different environments
+of definition. Not all such cases are supported yet, but it is intended
+that such support will be improved in future.
+\item It is easier to integrate with cross-module optimisation, since
+imported information about other modules is already in the correct
+intermediate language.
+\item It becomes more straightforward to optimise closure allocations since
+the layout of closures does not have to be estimated in any way: it is
+known. Similarly,
+it becomes more straightforward to control which variables end up
+in which closures, helping to avoid closure bloat.
+\end{itemize}
+
+\subsection{Classic inlining heuristic}\label{classic}
+
+In {\tt -Oclassic} mode the behaviour of the Flambda inliner
+mimics previous versions
+of the compiler. (Code may still be subject to further optimisations not
+performed by previous versions of the compiler: functors may be inlined,
+constants are lifted and unused code is eliminated all as described elsewhere
+in this chapter. See sections \ref{functors},\ \ref{lift-const} %
+and\ \ref{remove-unused}.
+At the definition site of a function, the body of the
+function is measured. It will then be marked as eligible for inlining
+(and hence inlined at every direct call site) if:
+\begin{itemize}
+\item the measured size (in unspecified units) is smaller than that of a
+function call plus the argument of the {\tt -inline} command-line flag; and
+\item the function is not recursive.
+\end{itemize}
+
+Non-Flambda versions of the compiler cannot inline functions that
+contain a definition of another function. However {\tt -Oclassic} does
+permit this. Further, non-Flambda versions also cannot inline functions
+that are only themselves exposed as a result of a previous pass of inlining,
+but again this is permitted by {\tt -Oclassic}.
+For example:
+\begin{verbatim}
+module M : sig
+ val i : int
+end = struct
+ let f x =
+ let g y = x + y in
+ g
+ let h = f 3
+ let i = h 4 (* h is correctly discovered to be g and inlined *)
+end
+\end{verbatim}
+
+All of this contrasts with the normal Flambda mode, that is to say
+without {\tt -Oclassic}, where:
+\begin{itemize}
+\item the inlining decision is made at the {\bf call site}; and
+\item recursive functions can be handled, by {\em specialisation} (see
+below).
+\end{itemize}
+The Flambda mode is described in the next section.
+
+\subsection{Overview of ``Flambda'' inlining heuristics}
+
+The Flambda inlining heuristics, used whenever the compiler is configured
+for Flambda and {\tt -Oclassic} was not specified, make inlining decisions
+at call sites. This helps in situations where the context is important.
+For example:
+\begin{verbatim}
+let f b x =
+ if b then
+ x
+ else
+ ... big expression ...
+
+let g x = f true x
+\end{verbatim}
+In this case, we would like to inline {\tt f} into {\tt g}, because a
+conditional jump can be eliminated and the code size should reduce. If the
+inlining decision has been made after the declaration of {\tt f} without
+seeing the use, its size would have probably made it ineligible for
+inlining; but at the call site, its final size can be known. Further,
+this function should probably not be inlined systematically: if {\tt b}
+is unknown, or indeed {\tt false}, there is little benefit to trade off
+against a large increase in code size. In the existing non-Flambda inliner
+this isn't a great problem because chains of inlining were cut off fairly
+quickly. However it has led to excessive use of overly-large inlining
+parameters such as {\tt -inline 10000}.
+
+In more detail, at each call site the following procedure is followed:
+\begin{itemize}
+\item Determine whether it is clear that inlining would be beneficial
+without, for the moment, doing any inlining within the function itself.
+(The exact assessment of {\em benefit} is described below.) If so, the
+function is inlined.
+\item If inlining the function is not clearly beneficial, then inlining
+will be performed {\em speculatively} inside the function itself. The
+search for speculative inlining possibilities is controlled by two
+parameters: the {\em inlining threshold} and the {\em inlining depth}.
+(These are described in more detail below.)
+\begin{itemize}
+\item If such speculation shows that performing some inlining inside the
+function would be beneficial, then such inlining is performed and the
+resulting function inlined at the original call site.
+\item Otherwise, nothing happens.
+\end{itemize}
+\end{itemize}
+Inlining within recursive functions of calls to other
+functions in the same mutually-recursive group is kept in check by
+an {\em unrolling depth}, described below. This ensures that functions are
+not unrolled to excess. (Unrolling is only enabled
+if {\tt -O3} optimisation level is selected and/or the
+{\tt -inline-max-unroll}
+flag is passed with an argument greater than zero.)
+
+\subsection{Handling of specific language constructs}
+
+\subsubsection{Functors}\label{functors}
+
+There is nothing particular about functors that inhibits inlining compared
+to normal functions. To the inliner, these both look the same, except
+that functors are marked as such.
+
+Applications of functors at toplevel are biased in favour of inlining.
+(This bias may be adjusted:
+see the documentation for {\tt -inline-lifting-benefit} below.)
+
+Applications of functors not at toplevel, for example in a local module
+inside some other expression, are treated by the inliner identically to
+normal function calls.
+
+\subsubsection{First-class modules}
+
+The inliner will be able to consider inlining a call to a function in a first
+class module if it knows which particular function is going to be called.
+The presence of the first-class module record that wraps the set of functions
+in the module does not per se inhibit inlining.
+
+\subsubsection{Objects}
+
+Method calls to objects are not at present inlined by Flambda.
+
+\subsection{Inlining reports}
+
+If the {\tt -inlining-report} option is provided to the compiler then a file
+will be emitted corresponding to each round of optimisation. For the
+OCaml source file {\em basename}{\tt .ml} the files
+are named {\em basename}{\tt .}{\em round}{\tt.inlining.org},
+with {\em round} a
+zero-based integer. Inside the files, which are formatted as ``org mode'',
+will be found English prose describing the decisions that the inliner took.
+
+\subsection{Assessment of inlining benefit}\label{assessment-inlining}
+
+Inlining typically
+results in an increase in code size, which if left unchecked, may not only
+lead to grossly large executables and excessive compilation times but also
+a decrease in performance due to worse locality. As such, the
+Flambda inliner trades off the change in code size against
+the expected runtime performance benefit, with the benefit being computed
+based on the number of operations that the compiler observes may be removed
+as a result of inlining.
+
+For example given the following code:
+\begin{verbatim}
+let f b x =
+ if b then
+ x
+ else
+ ... big expression ...
+
+let g x = f true x
+\end{verbatim}
+it would be observed that inlining of {\tt f} would remove:
+\begin{itemize}
+\item one direct call;
+\item one conditional branch.
+\end{itemize}
+
+Formally, an estimate of runtime performance benefit is computed by
+first summing
+the cost of the operations that are known to be removed as a result of the
+inlining and subsequent simplification of the inlined body.
+The individual costs for the various kinds of operations may be adjusted
+using the various {\tt -inline-...-cost} flags as follows. Costs are
+specified as integers. All of these flags accept a single argument
+describing such integers using the conventions
+detailed in section\ \ref{rounds}.
+\begin{options}
+\item[\machine{-inline-alloc-cost}] The cost of an allocation.
+\item[\machine{-inline-branch-cost}] The cost of a branch.
+\item[\machine{-inline-call-cost}] The cost of a direct function call.
+\item[\machine{-inline-indirect-cost}] The cost of an indirect function call.
+\item[\machine{-inline-prim-cost}] The cost of a {\em primitive}. Primitives
+encompass operations including arithmetic and memory access.
+\end{options}
+(Default values are described in section\ \ref{defaults} below.)
+
+The initial benefit value is then scaled by a factor that attempts to
+compensate for the fact that the current point in the code, if under some
+number of conditional branches, may be cold. (Flambda does not currently
+compute hot and cold paths.) The factor---the estimated probability that
+the inliner really is on a {\em hot} path---is calculated as
+$\frac{1}{(1 + f)^{d}}$, where $f$ is set by
+{\tt -inline-branch-factor} and $d$ is the nesting depth of branches
+at the current point. As the inliner descends into more deeply-nested
+branches, the benefit of inlining thus lessens.
+
+The resulting benefit value is known as the {\em estimated benefit}.
+
+The change in code size is also estimated: morally speaking it should be the
+change in machine code size, but since that is not available to the inliner,
+an approximation is used.
+
+If the estimated benefit exceeds the increase in code size then the inlined
+version of the function will be kept. Otherwise the function will not be
+inlined.
+
+Applications of functors at toplevel will be given
+an additional benefit (which may be controlled by the
+{\tt -inline-lifting-benefit} flag) to bias inlining in such situations
+towards keeping the inlined version.
+
+\subsection{Control of speculation}\label{speculation}
+
+As described above, there are three parameters that restrict the search
+for inlining opportunities during speculation:
+\begin{itemize}
+\item the {\em inlining threshold};
+\item the {\em inlining depth};
+\item the {\em unrolling depth}.
+\end{itemize}
+These parameters are ultimately bounded by the arguments provided to
+the corresponding command-line flags (or their default values):
+\begin{itemize}
+\item {\tt -inline} (or, if the call site that triggered speculation is
+at toplevel, {\tt -inline-toplevel});
+\item {\tt -inline-max-depth};
+\item {\tt -inline-max-unroll}.
+\end{itemize}
+{\bf Note in particular} that {\tt -inline} does not have the meaning that
+it has in the previous compiler or in {\tt -Oclassic} mode. In both of those
+situations {\tt -inline} was effectively some kind of basic assessment of
+inlining benefit. However in Flambda inlining mode it corresponds to a
+constraint on the search; the assessment of benefit is independent, as
+described above.
+
+When speculation starts the inlining threshold starts at the value set
+by {\tt -inline} (or {\tt -inline-toplevel} if appropriate, see above).
+Upon making a speculative inlining decision the
+threshold is reduced by the code size of the function being inlined.
+If the threshold becomes exhausted, at or below zero, no further speculation
+will be performed.
+
+The inlining depth starts at zero
+and is increased by one every time the inliner
+descends into another function. It is then decreased by one every time the
+inliner leaves such function. If the depth exceeds the value set by
+{\tt -inline-max-depth} then speculation stops. This parameter is intended
+as a general backstop for situations where the inlining
+threshold does not control the search sufficiently.
+
+The unrolling depth applies to calls within the same mutually-recursive
+group of functions. Each time an inlining of such a call is performed
+the depth is incremented by one when examining the resulting body. If the
+depth reaches the limit set by {\tt -inline-max-unroll} then speculation
+stops.
+
+\section{Specialisation}\label{specialisation}
+
+The inliner may discover a call site to a recursive function where
+something is known about the arguments: for example, they may be equal to
+some other variables currently in scope. In this situation it may be
+beneficial to {\em specialise} the function to those arguments. This is
+done by copying the declaration of the function (and any others involved
+in any same mutually-recursive declaration) and noting the extra information
+about the arguments. The arguments augmented by this information are known
+as {\em specialised arguments}. In order to try to ensure that specialisation
+is not performed uselessly, arguments are only specialised if it can be shown
+that they are {\em invariant}: in other words, during the execution of the
+recursive function(s) themselves, the arguments never change.
+
+Unless overridden by an attribute (see below), specialisation of a function
+will not be attempted if:
+\begin{itemize}
+\item the compiler is in {\tt -Oclassic} mode;
+\item the function is not obviously recursive;
+\item the function is not closed.
+\end{itemize}
+
+The compiler can prove invariance of function arguments across multiple
+functions within a recursive group (although this has some limitations,
+as shown by the example below).
+
+It should be noted that the {\em unboxing of closures} pass (see below)
+can introduce specialised arguments on non-recursive functions. (No other
+place in the compiler currently does this.)
+
+\paragraph{Example: the well-known {\tt List.iter} function}
+This function might be written like so:
+\begin{verbatim}
+let rec iter f l =
+ match l with
+ | [] -> ()
+ | h :: t ->
+ f h;
+ iter f t
+\end{verbatim}
+and used like this:
+\begin{verbatim}
+let print_int x =
+ print_endline (string_of_int x)
+
+let run xs =
+ iter print_int (List.rev xs)
+\end{verbatim}
+The argument {\tt f} to {\tt iter} is invariant so the function may be
+specialised:
+\begin{verbatim}
+let run xs =
+ let rec iter' f l =
+ (* The compiler knows: f holds the same value as foo throughout iter'. *)
+ match l with
+ | [] -> ()
+ | h :: t ->
+ f h;
+ iter' f t
+ in
+ iter' print_int (List.rev xs)
+\end{verbatim}
+The compiler notes down that for the function {\tt iter'}, the argument
+{\tt f} is specialised to the constant closure {\tt print\_int}. This
+means that the body of {\tt iter'} may be simplified:
+\begin{verbatim}
+let run xs =
+ let rec iter' f l =
+ (* The compiler knows: f holds the same value as foo throughout iter'. *)
+ match l with
+ | [] -> ()
+ | h :: t ->
+ print_int h; (* this is now a direct call *)
+ iter' f t
+ in
+ iter' print_int (List.rev xs)
+\end{verbatim}
+The call to {\tt print\_int} can indeed be inlined:
+\begin{verbatim}
+let run xs =
+ let rec iter' f l =
+ (* The compiler knows: f holds the same value as foo throughout iter'. *)
+ match l with
+ | [] -> ()
+ | h :: t ->
+ print_endline (string_of_int h);
+ iter' f t
+ in
+ iter' print_int (List.rev xs)
+\end{verbatim}
+The unused specialised argument {\tt f} may now be removed, leaving:
+\begin{verbatim}
+let run xs =
+ let rec iter' l =
+ match l with
+ | [] -> ()
+ | h :: t ->
+ print_endline (string_of_int h);
+ iter' t
+ in
+ iter' (List.rev xs)
+\end{verbatim}
+
+\paragraph{Aside on invariant parameters.} The compiler cannot currently
+detect invariance in cases such as the following.
+\begin{verbatim}
+let rec iter_swap f g l =
+ match l with
+ | [] -> ()
+ | 0 :: t ->
+ iter_swap g f l
+ | h :: t ->
+ f h;
+ iter_swap f g t
+\end{verbatim}
+
+\subsection{Assessment of specialisation benefit}
+
+The benefit of specialisation is assessed in a similar way as for inlining.
+Specialised argument information may mean that the body of the function
+being specialised can be simplified: the removed operations are accumulated
+into a benefit. This, together with the size of the duplicated (specialised)
+function declaration, is then assessed against the size of the call to the
+original function.
+
+\section{Default settings of parameters}\label{defaults}
+
+The default settings (when not using {\tt -Oclassic}) are for one
+round of optimisation using the following parameters.
+% CR-soon mshinwell: for 4.04, let's autogenerate these.
+
+\begin{tableau}{|l|l|}{Parameter}{Setting}
+\entree{{\tt -inline}}{10}
+\entree{{\tt -inline-branch-factor}}{0.1}
+\entree{{\tt -inline-alloc-cost}}{7}
+\entree{{\tt -inline-branch-cost}}{5}
+\entree{{\tt -inline-call-cost}}{5}
+\entree{{\tt -inline-indirect-cost}}{4}
+\entree{{\tt -inline-prim-cost}}{3}
+\entree{{\tt -inline-lifting-benefit}}{1300}
+\entree{{\tt -inline-toplevel}}{160}
+\entree{{\tt -inline-max-depth}}{1}
+\entree{{\tt -inline-max-unroll}}{0}
+\entree{{\tt -unbox-closures-factor}}{10}
+\end{tableau}
+
+\subsection{Settings at -O2 optimisation level}
+
+When {\tt -O2} is specified two rounds of optimisation are performed.
+The first round uses the default parameters (see above). The second uses
+the following parameters.
+
+\begin{tableau}{|l|l|}{Parameter}{Setting}
+\entree{{\tt -inline}}{25}
+\entree{{\tt -inline-branch-factor}}{Same as default}
+\entree{{\tt -inline-alloc-cost}}{Double the default}
+\entree{{\tt -inline-branch-cost}}{Double the default}
+\entree{{\tt -inline-call-cost}}{Double the default}
+\entree{{\tt -inline-indirect-cost}}{Double the default}
+\entree{{\tt -inline-prim-cost}}{Double the default}
+\entree{{\tt -inline-lifting-benefit}}{Same as default}
+\entree{{\tt -inline-toplevel}}{400}
+\entree{{\tt -inline-max-depth}}{2}
+\entree{{\tt -inline-max-unroll}}{Same as default}
+\entree{{\tt -unbox-closures-factor}}{Same as default}
+\end{tableau}
+
+\subsection{Settings at -O3 optimisation level}
+
+When {\tt -O3} is specified three rounds of optimisation are performed.
+The first two rounds are as for {\tt -O2}. The third round uses
+the following parameters.
+
+\begin{tableau}{|l|l|}{Parameter}{Setting}
+\entree{{\tt -inline}}{50}
+\entree{{\tt -inline-branch-factor}}{Same as default}
+\entree{{\tt -inline-alloc-cost}}{Triple the default}
+\entree{{\tt -inline-branch-cost}}{Triple the default}
+\entree{{\tt -inline-call-cost}}{Triple the default}
+\entree{{\tt -inline-indirect-cost}}{Triple the default}
+\entree{{\tt -inline-prim-cost}}{Triple the default}
+\entree{{\tt -inline-lifting-benefit}}{Same as default}
+\entree{{\tt -inline-toplevel}}{800}
+\entree{{\tt -inline-max-depth}}{3}
+\entree{{\tt -inline-max-unroll}}{1}
+\entree{{\tt -unbox-closures-factor}}{Same as default}
+\end{tableau}
+
+\section{Manual control of inlining and specialisation}
+
+Should the inliner prove recalcitrant and refuse to inline a particular
+function, or if the observed inlining decisions are not to the programmer's
+satisfaction for some other reason, inlining behaviour can be dictated by the
+programmer directly in the source code.
+One example where this might be appropriate is when the programmer,
+but not the compiler, knows that a particular function call is on a cold
+code path. It might be desirable to prevent inlining of the function so
+that the code size along the hot path is kept smaller, so as to increase
+locality.
+
+The inliner is directed using attributes.
+For non-recursive functions (and one-step unrolling of recursive functions,
+although {\tt \@unroll} is more clear for this purpose)
+the following are supported:
+\begin{options}
+\item[{\machine{\@\@inline always}} or {\machine{\@\@inline never}}] Attached
+to a {\em declaration} of a function or functor, these direct the inliner to
+either
+always or never inline, irrespective of the size/benefit calculation. (If
+the function is recursive then the body is substituted and no special
+action is taken for the recursive call site(s).)
+{\machine{\@\@inline}} with no argument is equivalent to
+{\machine{\@\@inline always}}.
+\item[{\machine{\@inlined always}} or {\machine{\@inlined never}}] Attached
+to a function {\em application}, these direct the inliner likewise. These
+attributes at call sites override any other attribute that may be present
+on the corresponding declaration.
+{\machine{\@inlined}} with no argument is equivalent to
+{\machine{\@inlined always}}.
+\end{options}
+
+For recursive functions the relevant attributes are:
+\begin{options}
+\item[{\machine{\@\@specialise always}} or {\machine{\@\@specialise never}}]%
+Attached to a declaration of a function
+or functor, this directs the inliner to either always or never
+specialise the function so
+long as it has appropriate contextual knowledge, irrespective of the
+size/benefit calculation.
+{\machine{\@\@specialise}} with no argument is equivalent to
+{\machine{\@\@specialise always}}.
+\item[{\machine{\@specialised always}} or {\machine{\@specialised never}}]%
+Attached to a function application, this
+directs the inliner likewise. This attribute at a call site overrides any
+other attribute that may be present on the corresponding declaration.
+(Note that the function will still only be specialised if there exist
+one or more invariant parameters whose values are known.)
+{\machine{\@specialised}} with no argument is equivalent to
+{\machine{\@specialised always}}.
+\item[{\machine{\@unrolled }}$n$] This attribute is attached to a function
+application and always takes an integer argument. Each time the inliner sees
+the attribute it behaves as follows:
+\begin{itemize}
+\item If $n$ is zero or less, nothing happens.
+\item Otherwise the function being called is substituted at the call site
+with its body having been rewritten such that
+any recursive calls to that function {\em or
+any others in the same mutually-recursive group} are annotated with the
+attribute {\tt unrolled(}$n - 1${\tt )}. Inlining may continue on that body.
+\end{itemize}
+As such, $n$ behaves as the ``maximum depth of unrolling''.
+\end{options}
+
+A compiler warning will be emitted if it was found impossible to obey an
+annotation from an {\tt \@inlined} or {\tt \@specialised} attribute.
+
+\paragraph{Example showing correct placement of attributes}
+\begin{verbatim}
+module F (M : sig type t end) = struct
+ let[@inline never] bar x =
+ x * 3
+
+ let foo x =
+ (bar [@inlined]) (42 + x)
+end [@@inline never]
+
+module X = F [@inlined] (struct type t = int end)
+\end{verbatim}
+
+\section{Simplification}
+
+Simplification, which is run in conjunction with inlining,
+propagates information (known as {\em approximations}) about which
+variables hold what values at runtime. Certain relationships between
+variables and symbols are also tracked: for example, some variable may be
+known to always hold the same value as some other variable; or perhaps
+some variable may be known to always hold the value pointed to by some
+symbol.
+
+The propagation can help to eliminate allocations in cases such as:
+\begin{verbatim}
+let f x y =
+ ...
+ let p = x, y in
+ ...
+ ... (fst p) ... (snd p) ...
+\end{verbatim}
+The projections from {\tt p} may be replaced by uses of the variables
+{\tt x} and {\tt y}, potentially meaning that {\tt p} becomes unused.
+
+The propagation performed by the simplification pass is also important for
+discovering which functions flow to indirect call sites. This can enable
+the transformation of such call sites into direct call sites, which makes
+them eligible for an inlining transformation.
+
+Note that no information is propagated about the contents of strings,
+even in {\tt safe-string} mode, because it cannot yet be guaranteed
+that they are immutable throughout a given program.
+
+\section{Other code motion transformations}
+
+\subsection{Lifting of constants}\label{lift-const}
+
+Expressions found to be constant will be lifted to symbol
+bindings---that is to say, they will be statically allocated in the
+object file---when
+they evaluate to boxed values. Such constants may be straightforward numeric
+constants, such as the floating-point number {\tt 42.0}, or more complicated
+values such as constant closures.
+
+Lifting of constants to toplevel reduces allocation at runtime.
+
+The compiler aims to share constants lifted to toplevel such that there
+are no duplicate definitions. However if {\tt .cmx} files are hidden
+from the compiler then maximal sharing may not be possible.
+
+\paragraph{Notes about float arrays} %
+The following language semantics apply specifically to constant float arrays.
+(By ``constant float array'' is meant an array consisting entirely of floating
+point numbers that are known at compile time. A common case is a literal
+such as {\tt [| 42.0; 43.0; |]}.
+\begin{itemize}
+\item Constant float arrays at the toplevel are mutable and never shared.
+(That is to say, for each
+such definition there is a distinct symbol in the data section of the object
+file pointing at the array.)
+\item Constant float arrays not at toplevel are mutable and are created each
+time the expression is evaluated. This can be thought of as an operation that
+takes an immutable array (which in the source code has no associated name; let
+us call it the {\em initialising array}) and
+duplicates it into a fresh mutable array.
+\begin{itemize}
+\item If the array is of size four or less, the expression will create a
+fresh block and write the values into it one by one. There is no reference
+to the initialising array as a whole.
+
+\item Otherwise, the initialising array is lifted out and subject to the
+normal constant sharing procedure;
+creation of the array consists of bulk copying the initialising array
+into a fresh value on the OCaml heap.
+\end{itemize}
+\end{itemize}
+
+\subsection{Lifting of toplevel let bindings}
+
+Toplevel {\tt let}-expressions may be lifted to symbol bindings to ensure
+that the corresponding bound variables are not captured by closures. If the
+defining expression of a given binding is found to be constant, it is bound
+as such (the technical term is a {\em let-symbol} binding).
+
+Otherwise, the symbol is bound to a (statically-allocated)
+{\em preallocated block} containing one field. At runtime, the defining
+expression will be evaluated and the first field of the block filled with
+the resulting value. This {\em initialise-symbol} binding
+causes one extra indirection but ensures, by
+virtue of the symbol's address being known at compile time, that uses of the
+value are not captured by closures.
+
+It should be noted that the blocks corresponding to initialise-symbol
+bindings are kept alive forever, by virtue of them occurring in a static
+table of GC roots within the object file. This extended lifetime of
+expressions may on occasion be surprising. If it is desired to create
+some non-constant value (for example when writing GC tests) that does not
+have this
+extended lifetime, then it may be created and used inside a function,
+with the application point of that function (perhaps at toplevel)---or
+indeed the function declaration itself---marked
+as to never be inlined. This technique prevents lifting of the definition
+of the value in question (assuming of course that it is not constant).
+
+\section{Unboxing transformations}
+
+The transformations in this section relate to the splitting apart of
+{\em boxed} (that is to say, non-immediate) values. They are largely
+intended to reduce allocation, which tends to result in a runtime
+performance profile with lower variance and smaller tails.
+
+\subsection{Unboxing of closure variables}\label{unbox-fvs}
+
+This transformation is enabled unless
+{\tt -no-unbox-free-vars-of-closures} is provided.
+
+Variables that appear in closure environments may themselves be boxed
+values. As such, they may be split into further closure variables, each
+of which corresponds to some projection from the original closure variable(s).
+This transformation is called {\em unboxing of closure variables} or
+{\em unboxing of free variables of closures}. It is only applied when
+there is
+reasonable certainty that there are no uses of the boxed free variable itself
+within the corresponding function bodies.
+% CR-someday mshinwell: Actually, we probably don't check this carefully
+% enough. It needs a global analysis in case there is an out-of-scope
+% projection.
+
+\paragraph{Example:} In the following code, the compiler observes that
+the closure returned from the function {\tt f} contains a variable {\tt pair}
+(free in the body of {\tt f}) that may be split into two separate variables.
+\begin{verbatim}
+let f x0 x1 =
+ let pair = x0, x1 in
+ Printf.printf "foo\n";
+ fun y ->
+ fst pair + snd pair + y
+\end{verbatim}
+After some simplification one obtains:
+\begin{verbatim}
+let f x0 x1 =
+ let pair_0 = x0 in
+ let pair_1 = x1 in
+ Printf.printf "foo\n";
+ fun y ->
+ pair_0 + pair_1 + y
+\end{verbatim}
+and then:
+\begin{verbatim}
+let f x0 x1 =
+ Printf.printf "foo\n";
+ fun y ->
+ x0 + x1 + y
+\end{verbatim}
+The allocation of the pair has been eliminated.
+
+This transformation does not operate if it would cause the closure to
+contain more than twice as many closure variables as it did beforehand.
+
+\subsection{Unboxing of specialised arguments}\label{unbox-spec-args}
+
+This transformation is enabled unless
+{\tt -no-unbox-specialised-args} is provided.
+
+It may become the case during compilation that one or more invariant arguments
+to a function become specialised to a particular value. When such values are
+themselves boxed the corresponding specialised arguments may be split into
+more specialised arguments corresponding to the projections out of the boxed
+value that occur within the function body. This transformation is called
+{\em unboxing of specialised arguments}. It is only applied when there is
+reasonable certainty that the boxed argument itself is unused within the
+function.
+
+If the function in question is involved in a recursive group then unboxing
+of specialised arguments may be immediately replicated across the group
+based on the dataflow between invariant arguments.
+
+\paragraph{Example:} Having been given the following code, the compiler
+will inline {\tt loop} into {\tt f}, and then observe {\tt inv}
+being invariant and always the pair formed by adding {\tt 42} and {\tt 43}
+to the argument {\tt x} of the function {\tt f}.
+\begin{verbatim}
+let rec loop inv xs =
+ match xs with
+ | [] -> fst inv + snd inv
+ | x::xs -> x + loop2 xs inv
+and loop2 ys inv =
+ match ys with
+ | [] -> 4
+ | y::ys -> y - loop inv ys
+
+let f x =
+ Printf.printf "%d\n" (loop (x + 42, x + 43) [1; 2; 3])
+\end{verbatim}
+Since the functions have sufficiently few arguments, more specialised
+arguments will be added. After some simplification one obtains:
+\begin{verbatim}
+let f x =
+ let rec loop' xs inv_0 inv_1 =
+ match xs with
+ | [] -> inv_0 + inv_1
+ | x::xs -> x + loop2' xs inv_0 inv_1
+ and loop2' ys inv_0 inv_1 =
+ match ys with
+ | [] -> 4
+ | y::ys -> y - loop' ys inv_0 inv_1
+ in
+ Printf.printf "%d\n" (loop' [1; 2; 3] (x + 42) (x + 43))
+\end{verbatim}
+The allocation of the pair within {\tt f} has been removed. (Since the
+two closures for {\tt loop'} and {\tt loop2'} are constant they will also be
+lifted to toplevel with no runtime allocation penalty. This
+would also happen without having run the transformation to unbox
+specialise arguments.)
+
+The transformation to unbox specialised arguments never introduces extra
+allocation.
+
+The transformation will not unbox arguments if it would result in the
+original function having sufficiently many arguments so as to inhibit
+tail-call optimisation.
+
+The transformation is implemented by creating a wrapper function that
+accepts the original arguments. Meanwhile, the original function is renamed
+and extra arguments are added corresponding to the unboxed specialised
+arguments; this new function
+is called from the wrapper. The wrapper will then be inlined
+at direct call sites. Indeed, all call sites will be direct unless
+{\tt -unbox-closures} is being used, since they will have been generated
+by the compiler when originally specialising the function. (In the case
+of {\tt -unbox-closures} other functions may appear with specialised
+arguments; in this case there may be indirect calls and these will incur
+a small penalty owing to having to bounce through the wrapper. The technique
+of {\em direct call surrogates} used for {\tt -unbox-closures} is not
+used by the transformation to unbox specialised arguments.)
+
+\subsection{Unboxing of closures}\label{unbox-closures}
+
+This transformation is {\em not} enabled by default. It may be enabled
+using the {\tt -unbox-closures} flag.
+
+The transformation replaces closure variables by specialised arguments.
+The aim is to cause more closures to become closed. It is particularly
+applicable, as a means of reducing allocation, where the function concerned
+cannot be inlined or specialised. For example, some non-recursive function
+might be too large to inline; or some recursive function might offer
+no opportunities for specialisation perhaps because its only argument is
+one of type {\tt unit}.
+
+At present there may be a small penalty in terms of actual runtime
+performance when this transformation is enabled, although more stable
+performance may be obtained due to reduced allocation. It is recommended
+that developers experiment to determine whether the option is beneficial
+for their code. (It is expected that in the future it will be possible
+for the performance degradation to be removed.)
+
+\paragraph{Simple example:} In the following code (which might typically
+occur when {\tt g} is too large to inline) the value of {\tt x} would usually
+be communicated to the application of the {\tt +} function via the closure
+of {\tt g}.
+\begin{verbatim}
+let f x =
+ let g y =
+ x + y
+ in
+ (g [@inlined never]) 42
+\end{verbatim}
+Unboxing of the closure causes the value for {\tt x} inside {\tt g} to
+be passed as an argument to {\tt g} rather than through its closure. This
+means that the closure of {\tt g} becomes constant and may be lifted to
+toplevel, eliminating the runtime allocation.
+
+The transformation is implemented by adding a new wrapper function in the
+manner of that used when unboxing specialised arguments. The closure
+variables are still free in the wrapper, but the intention is that when
+the wrapper is inlined at direct call sites, the relevant values are
+passed directly to the main function via the new specialised arguments.
+
+Adding such a wrapper will penalise indirect calls to the function
+(which might exist in arbitrary places; remember that this transformation
+is not for example applied only on functions the compiler has produced
+as a result of specialisation) since such calls will bounce through
+the wrapper. To
+mitigate this, if a function is small enough when weighed up against
+the number of free variables being removed, it will be duplicated by the
+transformation to obtain two versions: the original (used for indirect calls,
+since we can do no better) and the wrapper/rewritten function pair as
+described in the previous paragraph. The wrapper/rewritten function pair
+will only be used at direct call sites of the function. (The wrapper in
+this case is known as a {\em direct call surrogate}, since
+it takes the place of another function---the unchanged version used for
+indirect calls---at direct call sites.)
+
+The {\tt -unbox-closures-factor} command line flag, which takes an
+integer, may be used to adjust the point at which a function is deemed
+large enough to be ineligible for duplication. The benefit of
+duplication is scaled by the integer before being evaluated against the
+size.
+
+\paragraph{Harder example:} In the following code, there are two closure
+variables that would typically cause closure allocations. One is called
+{\tt fv} and occurs inside the function {\tt baz}; the other is called
+{\tt z} and occurs inside the function {\tt bar}.
+In this toy (yet sophisticated) example we again use an attribute to
+simulate the typical situation where the first argument of {\tt baz} is
+too large to inline.
+\begin{verbatim}
+let foo c =
+ let rec bar zs fv =
+ match zs with
+ | [] -> []
+ | z::zs ->
+ let rec baz f = function
+ | [] -> []
+ | a::l -> let r = fv + ((f [@inlined never]) a) in r :: baz f l
+ in
+ (map2 (fun y -> z + y) [z; 2; 3; 4]) @ bar zs fv
+ in
+ Printf.printf "%d" (List.length (bar [1; 2; 3; 4] c))
+\end{verbatim}
+The code resulting from applying {\tt -O3 -unbox-closures} to this code
+passes the free variables via function arguments in
+order to eliminate all closure allocation in this example (aside from any
+that might be performed inside {\tt printf}).
+
+\section{Removal of unused code and values}\label{remove-unused}
+
+\subsection{Removal of redundant let expressions}
+
+The simplification pass removes unused {\tt let} bindings so long as
+their corresponding defining expressions have ``no effects''. See
+the section ``Treatment of effects'' below for the precise definition of
+this term.
+
+\subsection{Removal of redundant program constructs}
+
+This transformation is analogous to the removal of {\tt let}-expressions
+whose defining expressions have no effects. It operates instead on symbol
+bindings, removing those that have no effects.
+
+\subsection{Removal of unused arguments}\label{remove-unused-args}
+
+This transformation is only enabled by default for specialised arguments.
+It may be enabled for all arguments using the {\tt -remove-unused-arguments}
+flag.
+
+The pass analyses functions to determine which arguments are unused.
+Removal is effected by creating a wrapper function, which will be inlined
+at every direct call site, that accepts the original arguments and then
+discards the unused ones before calling the original function. As a
+consequence, this transformation may be detrimental if the original
+function is usually indirectly called, since such calls will now bounce
+through the wrapper. (The technique of {\em direct call surrogates} used
+to reduce this penalty during unboxing of closure variables (see above)
+does not yet apply to the pass that removes unused arguments.)
+
+\subsection{Removal of unused closure variables}
+
+This transformation performs an analysis across
+the whole compilation unit to determine whether there exist closure variables
+that are never used. Such closure variables are then eliminated. (Note that
+this has to be a whole-unit analysis because a projection of a closure
+variable from some particular closure may have propagated to an arbitrary
+location within the code due to inlining.)
+
+\section{Other code transformations}
+
+\subsection{Transformation of non-escaping references into mutable variables}
+
+Flambda performs a simple analysis analogous to that performed elsewhere
+in the compiler that can transform {\tt ref}s into mutable variables
+that may then be held in registers (or on the stack as appropriate) rather
+than being allocated on the OCaml heap. This only happens so long as the
+reference concerned can be shown to not escape from its defining scope.
+
+\subsection{Substitution of closure variables for specialised arguments}
+
+This transformation discovers closure variables that are known to be
+equal to specialised arguments. Such closure variables are replaced by
+the specialised arguments; the closure variables may then be removed by
+the ``removal of unused closure variables'' pass (see below).
+
+\section{Treatment of effects}
+
+The Flambda optimisers classify expressions in order to determine whether
+an expression:
+\begin{itemize}
+\item does not need to be evaluated at all; and/or
+\item may be duplicated.
+\end{itemize}
+
+This is done by forming judgements on the {\em effects} and the {\em coeffects}
+that might be performed were the expression to be executed. Effects talk
+about how the expression might affect the world; coeffects talk about how
+the world might affect the expression.
+
+Effects are classified as follows:
+\begin{options}
+\item[{\bf No effects:}] The expression does not change the observable state
+of the world. For example, it must not write to any mutable storage,
+call arbitrary external functions or change control flow (e.g. by raising
+an exception). Note that allocation is {\em not} classed as having
+``no effects'' (see below).
+\begin{itemize}
+\item It is assumed in the compiler that expressions with no
+effects, whose results are not used, may be eliminated. (This typically
+happens where the expression in question is the defining expression of a
+{\tt let}; in such cases the {\tt let}-expression will be
+eliminated.) It is further
+assumed that such expressions with no effects may be
+duplicated (and thus possibly executed more than once).
+\item Exceptions arising from allocation points, for example
+``out of memory'' or
+exceptions propagated from finalizers or signal handlers, are treated as
+``effects out of the ether'' and thus ignored for our determination here
+of effectfulness. The same goes for floating point operations that may
+cause hardware traps on some platforms.
+\end{itemize}
+\item[{\bf Only generative effects:}] The expression does not change the
+observable state of the world save for possibly affecting the state of
+the garbage collector by performing an allocation. Expressions
+that only have generative effects and whose results are unused
+may be eliminated by the compiler. However, unlike expressions with
+``no effects'', such expressions will never be eligible for duplication.
+\item[{\bf Arbitrary effects:}] All other expressions.
+\end{options}
+
+There is a single classification for coeffects:
+\begin{options}
+\item[{\bf No coeffects:}] The expression does not observe the effects (in
+the sense described above) of other expressions. For example, it must not
+read from any mutable storage or call arbitrary external functions.
+\end{options}
+
+It is assumed in the compiler that, subject to data dependencies,
+expressions with neither effects nor coeffects may be reordered with
+respect to other expressions.
+
+\section{Compilation of statically-allocated modules}
+
+Compilation of modules that are able to be statically allocated (for example,
+the module corresponding to an entire compilation unit, as opposed to a first
+class module dependent on values computed at runtime) initially follows the
+strategy used for bytecode. A sequence of {\tt let}-bindings, which may be
+interspersed with arbitrary effects, surrounds a record creation that becomes
+the module block. The Flambda-specific transformation follows: these bindings
+are lifted to toplevel symbols, as described above.
+
+\section{Inhibition of optimisation}\label{inhibition}
+
+Especially when writing benchmarking suites that run non-side-effecting
+algorithms in loops, it may be found that the optimiser entirely
+elides the code being benchmarked. This behaviour can be prevented by
+using the {\tt Sys.opaque\_identity} function (which indeed behaves as a
+normal OCaml function and does not possess any ``magic'' semantics). The
+documentation of the {\tt Sys} module should be consulted for further details.
+
+\section{Use of unsafe operations}\label{unsafe}
+
+The behaviour of the Flambda simplification pass means that certain unsafe
+operations, which may without Flambda or when using previous versions of
+the compiler be safe, must not be used. This specifically refers to
+functions found in the {\tt Obj} module.
+
+In particular, it is forbidden to change any value (for example using
+{\tt Obj.set\_field} or {\tt Obj.set\_tag}) that is not mutable.
+(Values returned from C stubs
+are always treated as mutable.) The compiler will emit warning 59 if it
+detects such a write---but it cannot warn in all cases. Here is an example
+of code that will trigger the warning:
+\begin{verbatim}
+let f x =
+ let a = 42, x in
+ (Obj.magic a : int ref) := 1;
+ fst a
+\end{verbatim}
+The reason this is unsafe is because the simplification pass believes that
+{\tt fst a} holds the value {\tt 42}; and indeed it must, unless type
+soundness has been broken via unsafe operations.
+
+If it must be the case that code has to be written that triggers warning 59,
+but the code is known to actually be correct (for some definition of
+correct), then {\tt Sys.opaque\_identity} may be used to wrap the value
+before unsafe operations are performed upon it. Great care must be taken
+when doing this to ensure that the opacity is added at the correct place.
+It must be emphasised that this use of {\tt Sys.opaque\_identity} is only
+for {\bf exceptional} cases. It should not be used in normal code or to
+try to guide the optimiser.
+
+As an example, this code will return the integer {\tt 1}:
+\begin{verbatim}
+let f x =
+ let a = Sys.opaque_identity (42, x) in
+ (Obj.magic a : int ref) := 1;
+ fst a
+\end{verbatim}
+However the following code will still return {\tt 42}:
+\begin{verbatim}
+let f x =
+ let a = 42, x in
+ Sys.opaque_identity (Obj.magic a : int ref) := 1;
+ fst a
+\end{verbatim}
+
+High levels of inlining performed by Flambda may expose bugs in code
+thought previously to be correct. Take care, for example, not
+to add type annotations that claim some mutable value is always immediate
+if it might be possible for an unsafe operation to update it to a boxed
+value.
+
+\section{Glossary}
+
+The following terminology is used in this chapter of the manual.
+
+\begin{options}
+\item[{\bf Call site}] See {\em direct call site} and %
+{\em indirect call site} below.
+\item[{\bf Closed function}] A function whose body has no free variables
+except its parameters and any to which are bound other functions within
+the same (possibly mutually-recursive) declaration.
+\item[{\bf Closure}] The runtime representation of a function. This
+includes pointers to the code of the function
+together with the values of any variables that are used in the body of
+the function but actually defined outside of the function, in the
+enclosing scope.
+The values of such variables, collectively known as the
+{\em environment}, are required because the function may be
+invoked from a place where the original bindings of such variables are
+no longer in scope. A group of possibly
+mutually-recursive functions defined using {\em let rec} all share a
+single closure. (Note to developers: in the Flambda source code a
+{\em closure} always corresponds to a single function; a
+{\em set of closures} refers to a group of such.)
+\item[{\bf Closure variable}] A member of the environment held within the
+closure of a given function.
+\item[{\bf Constant}] Some entity (typically an expression) the value of which
+is known by the compiler at compile time. Constantness may be explicit from
+the source code or inferred by the Flambda optimisers.
+\item[{\bf Constant closure}] A closure that is statically allocated in an
+object file. It is almost always the case that the environment portion of
+such a closure is empty.
+\item[{\bf Defining expression}] The expression {\tt e} in %
+{\tt let x = e in e'}.
+\item[{\bf Direct call site}] A place in a program's code where a function is
+called and it is known at compile time which function it will always be.
+\item[{\bf Indirect call site}] A place in a program's code where a function
+is called but is not known to be a {\em direct call site}.
+\item[{\bf Program}] A collection of {\em symbol bindings} forming the
+definition of a single compilation unit (i.e. {\tt .cmx} file).
+\item[{\bf Specialised argument}] An argument to a function that is known
+to always hold a particular value at runtime. These are introduced by the
+inliner when specialising recursive functions; and the {\tt unbox-closures}
+pass. (See section\ \ref{specialisation}.)
+\item[{\bf Symbol}] A name referencing a particular place in an object file
+or executable image. At that particular place will be some constant value.
+Symbols may be examined using operating system-specific tools (for
+example {\tt objdump} on Linux).
+\item[{\bf Symbol binding}] Analogous to a {\tt let}-expression but working
+at the level of symbols defined in the object file. The address of a symbol is
+fixed, but it may be bound to both constant and non-constant expressions.
+\item[{\bf Toplevel}] An expression in the current program which is not
+enclosed within any function declaration.
+\item[{\bf Variable}] A named entity to which some OCaml value is bound by a
+{\tt let} expression, pattern-matching construction, or similar.
+\end{options}
--- /dev/null
+\chapter{Interfacing\label{c:intf-c} C with OCaml}
+\pdfchapterfold{-9}{Interfacing C with OCaml}
+%HEVEA\cutname{intfc.html}
+
+This chapter describes how user-defined primitives, written in C, can
+be linked with OCaml code and called from OCaml functions, and how
+these C functions can call back to OCaml code.
+
+\section{Overview and compilation information}
+\pdfsection{Overview and compilation information}
+
+\subsection{Declaring primitives}
+
+\begin{syntax}
+definition: ...
+ | 'external' value-name ':' typexpr '=' external-declaration
+;
+external-declaration: string-literal [ string-literal [ string-literal ] ]
+\end{syntax}
+
+User primitives are declared in an implementation file or
+@"struct"\ldots"end"@ module expression using the @"external"@ keyword:
+\begin{alltt}
+ external \var{name} : \var{type} = \var{C-function-name}
+\end{alltt}
+This defines the value name \var{name} as a function with type
+\var{type} that executes by calling the given C function.
+For instance, here is how the "input" primitive is declared in the
+standard library module "Pervasives":
+\begin{verbatim}
+ external input : in_channel -> bytes -> int -> int -> int
+ = "input"
+\end{verbatim}
+Primitives with several arguments are always curried. The C function
+does not necessarily have the same name as the ML function.
+
+External functions thus defined can be specified in interface files or
+@"sig"\ldots"end"@ signatures either as regular values
+\begin{alltt}
+ val \var{name} : \var{type}
+\end{alltt}
+thus hiding their implementation as C functions, or explicitly as
+``manifest'' external functions
+\begin{alltt}
+ external \var{name} : \var{type} = \var{C-function-name}
+\end{alltt}
+The latter is slightly more efficient, as it allows clients of the
+module to call directly the C function instead of going through the
+corresponding OCaml function. On the other hand, it should not be used
+in library modules if they have side-effects at toplevel, as this
+direct call interferes with the linker's algorithm for removing unused
+modules from libraries at link-time.
+
+The arity (number of arguments) of a primitive is automatically
+determined from its OCaml type in the "external" declaration, by
+counting the number of function arrows in the type. For instance,
+"input" above has arity 4, and the "input" C function is called with
+four arguments. Similarly,
+\begin{verbatim}
+ external input2 : in_channel * bytes * int * int -> int = "input2"
+\end{verbatim}
+has arity 1, and the "input2" C function receives one argument (which
+is a quadruple of OCaml values).
+
+Type abbreviations are not expanded when determining the arity of a
+primitive. For instance,
+\begin{verbatim}
+ type int_endo = int -> int
+ external f : int_endo -> int_endo = "f"
+ external g : (int -> int) -> (int -> int) = "f"
+\end{verbatim}
+"f" has arity 1, but "g" has arity 2. This allows a primitive to
+return a functional value (as in the "f" example above): just remember
+to name the functional return type in a type abbreviation.
+
+The language accepts external declarations with one or two
+flag strings in addition to the C function's name. These flags are
+reserved for the implementation of the standard library.
+
+\subsection{Implementing primitives}
+
+User primitives with arity $n \leq 5$ are implemented by C functions
+that take $n$ arguments of type "value", and return a result of type
+"value". The type "value" is the type of the representations for OCaml
+values. It encodes objects of several base types (integers,
+floating-point numbers, strings,~\ldots) as well as OCaml data
+structures. The type "value" and the associated conversion
+functions and macros are described in detail below. For instance,
+here is the declaration for the C function implementing the "input"
+primitive:
+\begin{verbatim}
+CAMLprim value input(value channel, value buffer, value offset, value length)
+{
+ ...
+}
+\end{verbatim}
+When the primitive function is applied in an OCaml program, the C
+function is called with the values of the expressions to which the
+primitive is applied as arguments. The value returned by the function is
+passed back to the OCaml program as the result of the function
+application.
+
+User primitives with arity greater than 5 should be implemented by two
+C functions. The first function, to be used in conjunction with the
+bytecode compiler "ocamlc", receives two arguments: a pointer to an
+array of OCaml values (the values for the arguments), and an
+integer which is the number of arguments provided. The other function,
+to be used in conjunction with the native-code compiler "ocamlopt",
+takes its arguments directly. For instance, here are the two C
+functions for the 7-argument primitive "Nat.add_nat":
+\begin{verbatim}
+CAMLprim value add_nat_native(value nat1, value ofs1, value len1,
+ value nat2, value ofs2, value len2,
+ value carry_in)
+{
+ ...
+}
+CAMLprim value add_nat_bytecode(value * argv, int argn)
+{
+ return add_nat_native(argv[0], argv[1], argv[2], argv[3],
+ argv[4], argv[5], argv[6]);
+}
+\end{verbatim}
+The names of the two C functions must be given in the primitive
+declaration, as follows:
+\begin{alltt}
+ external \var{name} : \var{type} =
+ \var{bytecode-C-function-name} \var{native-code-C-function-name}
+\end{alltt}
+For instance, in the case of "add_nat", the declaration is:
+\begin{verbatim}
+ external add_nat: nat -> int -> int -> nat -> int -> int -> int -> int
+ = "add_nat_bytecode" "add_nat_native"
+\end{verbatim}
+
+Implementing a user primitive is actually two separate tasks: on the
+one hand, decoding the arguments to extract C values from the given
+OCaml values, and encoding the return value as an OCaml
+value; on the other hand, actually computing the result from the arguments.
+Except for very simple primitives, it is often preferable to have two
+distinct C functions to implement these two tasks. The first function
+actually implements the primitive, taking native C values as
+arguments and returning a native C value. The second function,
+often called the ``stub code'', is a simple wrapper around the first
+function that converts its arguments from OCaml values to C values,
+call the first function, and convert the returned C value to OCaml
+value. For instance, here is the stub code for the "input"
+primitive:
+\begin{verbatim}
+CAMLprim value input(value channel, value buffer, value offset, value length)
+{
+ return Val_long(getblock((struct channel *) channel,
+ &Byte(buffer, Long_val(offset)),
+ Long_val(length)));
+}
+\end{verbatim}
+(Here, "Val_long", "Long_val" and so on are conversion macros for the
+type "value", that will be described later. The "CAMLprim" macro
+expands to the required compiler directives to ensure that the
+function is exported and accessible from OCaml.)
+The hard work is performed by the function "getblock", which is
+declared as:
+\begin{verbatim}
+long getblock(struct channel * channel, char * p, long n)
+{
+ ...
+}
+\end{verbatim}
+
+To write C code that operates on OCaml values, the following
+include files are provided:
+\begin{tableau}{|l|p{12cm}|}{Include file}{Provides}
+\entree{"caml/mlvalues.h"}{definition of the "value" type, and conversion
+macros}
+\entree{"caml/alloc.h"}{allocation functions (to create structured OCaml
+objects)}
+\entree{"caml/memory.h"}{miscellaneous memory-related functions
+and macros (for GC interface, in-place modification of structures, etc).}
+\entree{"caml/fail.h"}{functions for raising exceptions
+(see section~\ref{s:c-exceptions})}
+\entree{"caml/callback.h"}{callback from C to OCaml (see
+section~\ref{s:callback}).}
+\entree{"caml/custom.h"}{operations on custom blocks (see
+section~\ref{s:custom}).}
+\entree{"caml/intext.h"}{operations for writing user-defined
+serialization and deserialization functions for custom blocks
+(see section~\ref{s:custom}).}
+\entree{"caml/threads.h"}{operations for interfacing in the presence
+ of multiple threads (see section~\ref{s:C-multithreading}).}
+\end{tableau}
+These files reside in the "caml/" subdirectory of the OCaml
+standard library directory, which is returned by the command
+"ocamlc -where" (usually "/usr/local/lib/ocaml" or "/usr/lib/ocaml").
+
+By default, header files in the "caml/" subdirectory give only access
+to the public interface of the OCaml runtime. It is possible to define
+the macro "CAML_INTERNALS" to get access to a lower-level interface,
+but this lower-level interface is more likely to change and break
+programs that use it.
+
+{\bf Note:} It is recommended to define the macro "CAML_NAME_SPACE"
+before including these header files. If you do not define it, the
+header files will also define short names (without the "caml_" prefix)
+for most functions, which usually produce clashes with names defined
+by other C libraries that you might use. Including the header files
+without "CAML_NAME_SPACE" is only supported for backward
+compatibility.
+
+\subsection{Statically linking C code with OCaml code}
+\label{staticlink-c-code}
+
+The OCaml runtime system comprises three main parts: the bytecode
+interpreter, the memory manager, and a set of C functions that
+implement the primitive operations. Some bytecode instructions are
+provided to call these C functions, designated by their offset in a
+table of functions (the table of primitives).
+
+In the default mode, the OCaml linker produces bytecode for the
+standard runtime system, with a standard set of primitives. References
+to primitives that are not in this standard set result in the
+``unavailable C primitive'' error. (Unless dynamic loading of C
+libraries is supported -- see section~\ref{dynlink-c-code} below.)
+
+In the ``custom runtime'' mode, the OCaml linker scans the
+object files and determines the set of required primitives. Then, it
+builds a suitable runtime system, by calling the native code linker with:
+\begin{itemize}
+\item the table of the required primitives;
+\item a library that provides the bytecode interpreter, the
+memory manager, and the standard primitives;
+\item libraries and object code files (".o" files) mentioned on the
+command line for the OCaml linker, that provide implementations
+for the user's primitives.
+\end{itemize}
+This builds a runtime system with the required primitives. The OCaml
+linker generates bytecode for this custom runtime system. The
+bytecode is appended to the end of the custom runtime system, so that
+it will be automatically executed when the output file (custom
+runtime + bytecode) is launched.
+
+To link in ``custom runtime'' mode, execute the "ocamlc" command with:
+\begin{itemize}
+\item the "-custom" option;
+\item the names of the desired OCaml object files (".cmo" and ".cma" files) ;
+\item the names of the C object files and libraries (".o" and ".a"
+files) that implement the required primitives. Under Unix and Windows,
+a library named "lib"\var{name}".a" (respectively, ".lib") residing in one of
+the standard library directories can also be specified as "-cclib -l"\var{name}.
+\end{itemize}
+
+If you are using the native-code compiler "ocamlopt", the "-custom"
+flag is not needed, as the final linking phase of "ocamlopt" always
+builds a standalone executable. To build a mixed OCaml/C executable,
+execute the "ocamlopt" command with:
+\begin{itemize}
+\item the names of the desired OCaml native object files (".cmx" and
+".cmxa" files);
+\item the names of the C object files and libraries (".o", ".a",
+".so" or ".dll" files) that implement the required primitives.
+\end{itemize}
+
+Starting with Objective Caml 3.00, it is possible to record the
+"-custom" option as well as the names of C libraries in an OCaml
+library file ".cma" or ".cmxa". For instance, consider an OCaml library
+"mylib.cma", built from the OCaml object files "a.cmo" and "b.cmo",
+which reference C code in "libmylib.a". If the library is
+built as follows:
+\begin{alltt}
+ ocamlc -a -o mylib.cma -custom a.cmo b.cmo -cclib -lmylib
+\end{alltt}
+users of the library can simply link with "mylib.cma":
+\begin{alltt}
+ ocamlc -o myprog mylib.cma ...
+\end{alltt}
+and the system will automatically add the "-custom" and "-cclib
+-lmylib" options, achieving the same effect as
+\begin{alltt}
+ ocamlc -o myprog -custom a.cmo b.cmo ... -cclib -lmylib
+\end{alltt}
+The alternative is of course to build the library without extra
+options:
+\begin{alltt}
+ ocamlc -a -o mylib.cma a.cmo b.cmo
+\end{alltt}
+and then ask users to provide the "-custom" and "-cclib -lmylib"
+options themselves at link-time:
+\begin{alltt}
+ ocamlc -o myprog -custom mylib.cma ... -cclib -lmylib
+\end{alltt}
+The former alternative is more convenient for the final users of the
+library, however.
+
+\subsection{Dynamically linking C code with OCaml code}
+\label{dynlink-c-code}
+
+Starting with Objective Caml 3.03, an alternative to static linking of C code
+using the "-custom" code is provided. In this mode, the OCaml linker
+generates a pure bytecode executable (no embedded custom runtime
+system) that simply records the names of dynamically-loaded libraries
+containing the C code. The standard OCaml runtime system "ocamlrun"
+then loads dynamically these libraries, and resolves references to the
+required primitives, before executing the bytecode.
+
+This facility is currently supported and known to work well under
+Linux, MacOS~X, and Windows. It is supported, but not
+fully tested yet, under FreeBSD, Tru64, Solaris and Irix. It is not
+supported yet under other Unixes.
+
+To dynamically link C code with OCaml code, the C code must first be
+compiled into a shared library (under Unix) or DLL (under Windows).
+This involves 1- compiling the C files with appropriate C compiler
+flags for producing position-independent code (when required by the
+operating system), and 2- building a
+shared library from the resulting object files. The resulting shared
+library or DLL file must be installed in a place where "ocamlrun" can
+find it later at program start-up time (see
+section~\ref{s-ocamlrun-dllpath}).
+Finally (step 3), execute the "ocamlc" command with
+\begin{itemize}
+\item the names of the desired OCaml object files (".cmo" and ".cma" files) ;
+\item the names of the C shared libraries (".so" or ".dll" files) that
+implement the required primitives. Under Unix and Windows,
+a library named "dll"\var{name}".so" (respectively, ".dll") residing
+in one of the standard library directories can also be specified as
+"-dllib -l"\var{name}.
+\end{itemize}
+Do {\em not} set the "-custom" flag, otherwise you're back to static linking
+as described in section~\ref{staticlink-c-code}.
+The "ocamlmklib" tool (see section~\ref{s-ocamlmklib})
+automates steps 2 and 3.
+
+As in the case of static linking, it is possible (and recommended) to
+record the names of C libraries in an OCaml ".cma" library archive.
+Consider again an OCaml library
+"mylib.cma", built from the OCaml object files "a.cmo" and "b.cmo",
+which reference C code in "dllmylib.so". If the library is
+built as follows:
+\begin{alltt}
+ ocamlc -a -o mylib.cma a.cmo b.cmo -dllib -lmylib
+\end{alltt}
+users of the library can simply link with "mylib.cma":
+\begin{alltt}
+ ocamlc -o myprog mylib.cma ...
+\end{alltt}
+and the system will automatically add the "-dllib -lmylib" option,
+achieving the same effect as
+\begin{alltt}
+ ocamlc -o myprog a.cmo b.cmo ... -dllib -lmylib
+\end{alltt}
+Using this mechanism, users of the library "mylib.cma" do not need to
+known that it references C code, nor whether this C code must be
+statically linked (using "-custom") or dynamically linked.
+
+\subsection{Choosing between static linking and dynamic linking}
+
+After having described two different ways of linking C code with OCaml
+code, we now review the pros and cons of each, to help developers of
+mixed OCaml/C libraries decide.
+
+The main advantage of dynamic linking is that it preserves the
+platform-independence of bytecode executables. That is, the bytecode
+executable contains no machine code, and can therefore be compiled on
+platform $A$ and executed on other platforms $B$, $C$, \ldots, as long
+as the required shared libraries are available on all these
+platforms. In contrast, executables generated by "ocamlc -custom" run
+only on the platform on which they were created, because they embark a
+custom-tailored runtime system specific to that platform. In
+addition, dynamic linking results in smaller executables.
+
+Another advantage of dynamic linking is that the final users of the
+library do not need to have a C compiler, C linker, and C runtime
+libraries installed on their machines. This is no big deal under
+Unix and Cygwin, but many Windows users are reluctant to install
+Microsoft Visual C just to be able to do "ocamlc -custom".
+
+There are two drawbacks to dynamic linking. The first is that the
+resulting executable is not stand-alone: it requires the shared
+libraries, as well as "ocamlrun", to be installed on the machine
+executing the code. If you wish to distribute a stand-alone
+executable, it is better to link it statically, using "ocamlc -custom
+-ccopt -static" or "ocamlopt -ccopt -static". Dynamic linking also
+raises the ``DLL hell'' problem: some care must be taken to ensure
+that the right versions of the shared libraries are found at start-up
+time.
+
+The second drawback of dynamic linking is that it complicates the
+construction of the library. The C compiler and linker flags to
+compile to position-independent code and build a shared library vary
+wildly between different Unix systems. Also, dynamic linking is not
+supported on all Unix systems, requiring a fall-back case to static
+linking in the Makefile for the library. The "ocamlmklib" command
+(see section~\ref{s-ocamlmklib}) tries to hide some of these system
+dependencies.
+
+In conclusion: dynamic linking is highly recommended under the native
+Windows port, because there are no portability problems and it is much
+more convenient for the end users. Under Unix, dynamic linking should
+be considered for mature, frequently used libraries because it
+enhances platform-independence of bytecode executables. For new or
+rarely-used libraries, static linking is much simpler to set up in a
+portable way.
+
+\subsection{Building standalone custom runtime systems}
+\label{s:custom-runtime}
+
+It is sometimes inconvenient to build a custom runtime system each
+time OCaml code is linked with C libraries, like "ocamlc -custom" does.
+For one thing, the building of the runtime system is slow on some
+systems (that have bad linkers or slow remote file systems); for
+another thing, the platform-independence of bytecode files is lost,
+forcing to perform one "ocamlc -custom" link per platform of interest.
+
+An alternative to "ocamlc -custom" is to build separately a custom
+runtime system integrating the desired C libraries, then generate
+``pure'' bytecode executables (not containing their own runtime
+system) that can run on this custom runtime. This is achieved by the
+"-make-runtime" and "-use-runtime" flags to "ocamlc". For example,
+to build a custom runtime system integrating the C parts of the
+``Unix'' and ``Threads'' libraries, do:
+\begin{verbatim}
+ ocamlc -make-runtime -o /home/me/ocamlunixrun unix.cma threads.cma
+\end{verbatim}
+To generate a bytecode executable that runs on this runtime system,
+do:
+\begin{alltt}
+ ocamlc -use-runtime /home/me/ocamlunixrun -o myprog \char92
+ unix.cma threads.cma {\it{your .cmo and .cma files}}
+\end{alltt}
+The bytecode executable "myprog" can then be launched as usual:
+"myprog" \var{args} or "/home/me/ocamlunixrun myprog" \var{args}.
+
+Notice that the bytecode libraries "unix.cma" and "threads.cma" must
+be given twice: when building the runtime system (so that "ocamlc"
+knows which C primitives are required) and also when building the
+bytecode executable (so that the bytecode from "unix.cma" and
+"threads.cma" is actually linked in).
+
+\section{The \texttt{value} type}
+\pdfsection{The value type}
+
+All OCaml objects are represented by the C type "value",
+defined in the include file "caml/mlvalues.h", along with macros to
+manipulate values of that type. An object of type "value" is either:
+\begin{itemize}
+\item an unboxed integer;
+\item a pointer to a block inside the heap (such as the blocks
+allocated through one of the \verb"caml_alloc_*" functions below);
+\item a pointer to an object outside the heap (e.g., a pointer to a block
+allocated by "malloc", or to a C variable).
+ %%% FIXME will change in 4.02.0 (?)
+\end{itemize}
+
+\subsection{Integer values}
+
+Integer values encode 63-bit signed integers (31-bit on 32-bit
+architectures). They are unboxed (unallocated).
+
+\subsection{Blocks}
+
+Blocks in the heap are garbage-collected, and therefore have strict
+structure constraints. Each block includes a header containing the
+size of the block (in words), and the tag of the block.
+The tag governs how the contents of the blocks are structured. A tag
+lower than "No_scan_tag" indicates a structured block, containing
+well-formed values, which is recursively traversed by the garbage
+collector. A tag greater than or equal to "No_scan_tag" indicates a
+raw block, whose contents are not scanned by the garbage collector.
+For the benefit of ad-hoc polymorphic primitives such as equality and
+structured input-output, structured and raw blocks are further
+classified according to their tags as follows:
+\begin{tableau}{|l|p{10cm}|}{Tag}{Contents of the block}
+\entree{0 to $\hbox{"No_scan_tag"}-1$}{A structured block (an array of
+OCaml objects). Each field is a "value".}
+\entree{"Closure_tag"}{A closure representing a functional value. The first
+word is a pointer to a piece of code, the remaining words are
+"value" containing the environment.}
+\entree{"String_tag"}{A character string or a byte sequence.}
+\entree{"Double_tag"}{A double-precision floating-point number.}
+\entree{"Double_array_tag"}{An array or record of double-precision
+floating-point numbers.}
+\entree{"Abstract_tag"}{A block representing an abstract datatype.}
+\entree{"Custom_tag"}{A block representing an abstract datatype
+ with user-defined finalization, comparison, hashing,
+ serialization and deserialization functions atttached.}
+\end{tableau}
+
+\subsection{Pointers outside the heap}
+
+Any word-aligned pointer to an address outside the heap can be safely
+cast to and from the type "value". This includes pointers returned by
+"malloc", and pointers to C variables (of size at least one word)
+obtained with the \verb'&' operator.
+ %%% FIXME will change in 4.02.0 (?)
+
+Caution: if a pointer returned by "malloc" is cast to the type "value"
+and returned to OCaml, explicit deallocation of the pointer using
+"free" is potentially dangerous, because the pointer may still be
+accessible from the OCaml world. Worse, the memory space deallocated
+by "free" can later be reallocated as part of the OCaml heap; the
+pointer, formerly pointing outside the OCaml heap, now points inside
+the OCaml heap, and this can crash the garbage collector. To avoid
+these problems, it is preferable to wrap the pointer in a OCaml block
+with tag "Abstract_tag" or "Custom_tag".
+
+\section{Representation of OCaml data types}
+\pdfsection{Representation of OCaml data types}
+
+This section describes how OCaml data types are encoded in the
+"value" type.
+
+\subsection{Atomic types}
+
+\begin{tableau}{|l|l|}{OCaml type}{Encoding}
+\entree{"int"}{Unboxed integer values.}
+\entree{"char"}{Unboxed integer values (ASCII code).}
+\entree{"float"}{Blocks with tag "Double_tag".}
+\entree{"bytes"}{Blocks with tag "String_tag".}
+\entree{"string"}{Blocks with tag "String_tag".}
+\entree{"int32"}{Blocks with tag "Custom_tag".}
+\entree{"int64"}{Blocks with tag "Custom_tag".}
+\entree{"nativeint"}{Blocks with tag "Custom_tag".}
+\end{tableau}
+
+\subsection{Tuples and records}
+\label{ss:tuples-and-records}
+
+Tuples are represented by pointers to blocks, with tag~0.
+
+Records are also represented by zero-tagged blocks. The ordering of
+labels in the record type declaration determines the layout of
+the record fields: the value associated to the label
+declared first is stored in field~0 of the block, the value associated
+to the second label goes in field~1, and so on.
+
+As an optimization, records whose fields all have static type "float"
+are represented as arrays of floating-point numbers, with tag
+"Double_array_tag". (See the section below on arrays.)
+
+As another optimization, unboxable record types are represented
+specially; unboxable record types are the immutable record types that
+have only one field. An unboxable type will be represented in one of
+two ways: boxed or unboxed. Boxed record types are represented as
+described above (by a block with tag 0 or "Double_array_tag"). An
+unboxed record type is represented directly by the value of its field
+(i.e. there is no block to represent the record itself).
+
+The representation is chosen according to the following, in decreasing
+order of priority:
+\begin{itemize}
+\item An attribute ("[\@\@boxed]" or "[\@\@unboxed]") on the type declaration.
+\item A compiler option ("-unboxed-types" or "-no-unboxed-types").
+\item The default representation. In the present version of OCaml, the
+default is the boxed representation.
+\end{itemize}
+
+\subsection{Arrays}
+
+Arrays of integers and pointers are represented like tuples,
+that is, as pointers to blocks tagged~0. They are accessed with the
+"Field" macro for reading and the "caml_modify" function for writing.
+
+Arrays of floating-point numbers (type "float array")
+have a special, unboxed, more efficient representation.
+These arrays are represented by pointers to blocks with tag
+"Double_array_tag". They should be accessed with the "Double_field"
+and "Store_double_field" macros.
+
+\subsection{Concrete data types}
+
+Constructed terms are represented either by unboxed integers (for
+constant constructors) or by blocks whose tag encode the constructor
+(for non-constant constructors). The constant constructors and the
+non-constant constructors for a given concrete type are numbered
+separately, starting from 0, in the order in which they appear in the
+concrete type declaration. A constant constructor is represented by
+the unboxed integer equal to its constructor number. A non-constant
+constructor declared with $n$ arguments is represented by
+a block of size $n$, tagged with the constructor number; the $n$
+fields contain its arguments. Example:
+
+\begin{tableau}{|l|p{8cm}|}{Constructed term}{Representation}
+\entree{"()"}{"Val_int(0)"}
+\entree{"false"}{"Val_int(0)"}
+\entree{"true"}{"Val_int(1)"}
+\entree{"[]"}{"Val_int(0)"}
+\entree{"h::t"}{Block with size = 2 and tag = 0; first field
+contains "h", second field "t".}
+\end{tableau}
+
+As a convenience, "caml/mlvalues.h" defines the macros "Val_unit",
+"Val_false" and "Val_true" to refer to "()", "false" and "true".
+
+The following example illustrates the assignment of
+integers and block tags to constructors:
+\begin{verbatim}
+type t =
+ | A (* First constant constructor -> integer "Val_int(0)" *)
+ | B of string (* First non-constant constructor -> block with tag 0 *)
+ | C (* Second constant constructor -> integer "Val_int(1)" *)
+ | D of bool (* Second non-constant constructor -> block with tag 1 *)
+ | E of t * t (* Third non-constant constructor -> block with tag 2 *)
+\end{verbatim}
+
+
+As an optimization, unboxable concrete data types are represented
+specially; a concrete data type is unboxable if it has exactly one
+constructor and this constructor has exactly one argument. Unboxable
+concrete data types are represented in the same ways as unboxable
+record types: see the description in
+section~\ref{ss:tuples-and-records}.
+
+\subsection{Objects}
+
+Objects are represented as blocks with tag "Object_tag". The first
+field of the block refers to the object's class and associated method
+suite, in a format that cannot easily be exploited from C. The second
+field contains a unique object ID, used for comparisons. The remaining
+fields of the object contain the values of the instance variables of
+the object. It is unsafe to access directly instance variables, as the
+type system provides no guarantee about the instance variables
+contained by an object.
+% Instance variables are stored in the order in which they
+% appear in the class definition (taking inherited classes into
+% account).
+
+One may extract a public method from an object using the C function
+"caml_get_public_method" (declared in "<caml/mlvalues.h>".)
+Since public method tags are hashed in the same way as variant tags,
+and methods are functions taking self as first argument, if you want
+to do the method call "foo#bar" from the C side, you should call:
+\begin{verbatim}
+ callback(caml_get_public_method(foo, hash_variant("bar")), foo);
+\end{verbatim}
+
+\subsection{Polymorphic variants}
+
+Like constructed terms, polymorphic variant values are represented either
+as integers (for polymorphic variants without argument), or as blocks
+(for polymorphic variants with an argument). Unlike constructed
+terms, variant constructors are not numbered starting from 0, but
+identified by a hash value (an OCaml integer), as computed by the C function
+"hash_variant" (declared in "<caml/mlvalues.h>"):
+the hash value for a variant constructor named, say, "VConstr"
+is "hash_variant(\"VConstr\")".
+
+The variant value "`VConstr" is represented by
+"hash_variant(\"VConstr\")". The variant value "`VConstr("\var{v}")" is
+represented by a block of size 2 and tag 0, with field number 0
+containing "hash_variant(\"VConstr\")" and field number 1 containing
+\var{v}.
+
+Unlike constructed values, polymorphic variant values taking several
+arguments are not flattened.
+That is, "`VConstr("\var{v}", "\var{w}")" is represented by a block
+of size 2, whose field number 1 contains the representation of the
+pair "("\var{v}", "\var{w}")", rather than a block of size 3
+containing \var{v} and \var{w} in fields 1 and 2.
+
+\section{Operations on values}
+\pdfsection{Operations on values}
+
+\subsection{Kind tests}
+
+\begin{itemize}
+\item "Is_long("\var{v}")" is true if value \var{v} is an immediate integer,
+false otherwise
+\item "Is_block("\var{v}")" is true if value \var{v} is a pointer to a block,
+and false if it is an immediate integer.
+\end{itemize}
+
+\subsection{Operations on integers}
+
+\begin{itemize}
+\item "Val_long("\var{l}")" returns the value encoding the "long int" \var{l}.
+\item "Long_val("\var{v}")" returns the "long int" encoded in value \var{v}.
+\item "Val_int("\var{i}")" returns the value encoding the "int" \var{i}.
+\item "Int_val("\var{v}")" returns the "int" encoded in value \var{v}.
+\item "Val_bool("\var{x}")" returns the OCaml boolean representing the
+truth value of the C integer \var{x}.
+\item "Bool_val("\var{v}")" returns 0 if \var{v} is the OCaml boolean
+"false", 1 if \var{v} is "true".
+\item "Val_true", "Val_false" represent the OCaml booleans "true" and "false".
+\end{itemize}
+
+\subsection{Accessing blocks}
+
+\begin{itemize}
+\item "Wosize_val("\var{v}")" returns the size of the block \var{v}, in words,
+excluding the header.
+\item "Tag_val("\var{v}")" returns the tag of the block \var{v}.
+\item "Field("\var{v}", "\var{n}")" returns the value contained in the
+$n\th$ field of the structured block \var{v}. Fields are numbered from 0 to
+$\hbox{"Wosize_val"}(v)-1$.
+\item "Store_field("\var{b}", "\var{n}", "\var{v}")" stores the value
+\var{v} in the field number \var{n} of value \var{b}, which must be a
+structured block.
+\item "Code_val("\var{v}")" returns the code part of the closure \var{v}.
+\item "caml_string_length("\var{v}")" returns the length (number of bytes)
+of the string or byte sequence \var{v}.
+\item "Byte("\var{v}", "\var{n}")" returns the $n\th$ byte of the string
+or byte sequence \var{v}, with type "char". Bytes are numbered from 0 to
+$\hbox{"string_length"}(v)-1$.
+\item "Byte_u("\var{v}", "\var{n}")" returns the $n\th$ byte of the string
+or byte sequence \var{v}, with type "unsigned char". Bytes are
+numbered from 0 to $\hbox{"string_length"}(v)-1$.
+\item "String_val("\var{v}")" returns a pointer to the first byte of the string
+\var{v}, with type "char *" or, when OCaml is configured with
+"-force-safe-string", with type "const char *".
+This pointer is a valid C string: there is a null byte after the last
+byte in the string. However, OCaml strings can contain embedded null bytes,
+which will confuse the usual C functions over strings.
+\item "Bytes_val("\var{v}")" returns a pointer to the first byte of the
+byte sequence \var{v}, with type "unsigned char *".
+\item "Double_val("\var{v}")" returns the floating-point number contained in
+value \var{v}, with type "double".
+\item "Double_field("\var{v}", "\var{n}")" returns
+the $n\th$ element of the array of floating-point numbers \var{v} (a
+block tagged "Double_array_tag").
+\item "Store_double_field("\var{v}", "\var{n}",
+"\var{d}")" stores the double precision floating-point number \var{d}
+in the $n\th$ element of the array of floating-point numbers \var{v}.
+\item "Data_custom_val("\var{v}")" returns a pointer to the data part
+of the custom block \var{v}. This pointer has type "void *" and must
+be cast to the type of the data contained in the custom block.
+\item "Int32_val("\var{v}")" returns the 32-bit integer contained
+in the "int32" \var{v}.
+\item "Int64_val("\var{v}")" returns the 64-bit integer contained
+in the "int64" \var{v}.
+\item "Nativeint_val("\var{v}")" returns the long integer contained
+in the "nativeint" \var{v}.
+\item "caml_field_unboxed("\var{v}")" returns the value of the field
+of a value \var{v} of any unboxed type (record or concrete data type).
+\item "caml_field_boxed("\var{v}")" returns the value of the field
+of a value \var{v} of any boxed type (record or concrete data type).
+\item "caml_field_unboxable("\var{v}")" calls either
+"caml_field_unboxed" or "caml_field_boxed" according to the default
+representation of unboxable types in the current version of OCaml.
+\end{itemize}
+The expressions "Field("\var{v}", "\var{n}")",
+"Byte("\var{v}", "\var{n}")" and
+"Byte_u("\var{v}", "\var{n}")"
+are valid l-values. Hence, they can be assigned to, resulting in an
+in-place modification of value \var{v}.
+Assigning directly to "Field("\var{v}", "\var{n}")" must
+be done with care to avoid confusing the garbage collector (see
+below).
+
+\subsection{Allocating blocks}
+
+\subsubsection{Simple interface}
+
+\begin{itemize}
+\item
+"Atom("\var{t}")" returns an ``atom'' (zero-sized block) with tag \var{t}.
+Zero-sized blocks are preallocated outside of the heap. It is
+incorrect to try and allocate a zero-sized block using the functions below.
+For instance, "Atom(0)" represents the empty array.
+\item
+"caml_alloc("\var{n}", "\var{t}")" returns a fresh block of size \var{n}
+with tag \var{t}. If \var{t} is less than "No_scan_tag", then the
+fields of the block are initialized with a valid value in order to
+satisfy the GC constraints.
+\item
+"caml_alloc_tuple("\var{n}")" returns a fresh block of size
+\var{n} words, with tag 0.
+\item
+"caml_alloc_string("\var{n}")" returns a byte sequence (or string) value of
+length \var{n} bytes. The sequence initially contains uninitialized bytes.
+\item
+"caml_alloc_initialized_string("\var{n}", "\var{p}")" returns a byte sequence
+(or string) value of length \var{n} bytes. The value is initialized from the
+\var{n} bytes starting at address \var{p}.
+\item
+"caml_copy_string("\var{s}")" returns a string or byte sequence value
+containing a copy of the null-terminated C string \var{s} (a "char *").
+\item
+"caml_copy_double("\var{d}")" returns a floating-point value initialized
+with the "double" \var{d}.
+\item
+"caml_copy_int32("\var{i}")", "caml_copy_int64("\var{i}")" and
+"caml_copy_nativeint("\var{i}")" return a value of OCaml type "int32",
+"int64" and "nativeint", respectively, initialized with the integer
+\var{i}.
+\item
+"caml_alloc_array("\var{f}", "\var{a}")" allocates an array of values, calling
+function \var{f} over each element of the input array \var{a} to transform it
+into a value. The array \var{a} is an array of pointers terminated by the
+null pointer. The function \var{f} receives each pointer as argument, and
+returns a value. The zero-tagged block returned by
+"alloc_array("\var{f}", "\var{a}")" is filled with the values returned by the
+successive calls to \var{f}. (This function must not be used to build
+an array of floating-point numbers.)
+\item
+"caml_copy_string_array("\var{p}")" allocates an array of strings or byte
+sequences, copied from the pointer to a string array \var{p}
+(a "char **"). \var{p} must be NULL-terminated.
+\item "caml_alloc_float_array("\var{n}")" allocates an array of floating point
+ numbers of size \var{n}. The array initially contains uninitialized values.
+\item "caml_alloc_unboxed("\var{v}")" returns the value (of any unboxed
+type) whose field is the value \var{v}.
+\item "caml_alloc_boxed("\var{v}")" allocates and returns a value (of
+any boxed type) whose field is the value \var{v}.
+\item "caml_alloc_unboxable("\var{v}")" calls either
+"caml_alloc_unboxed" or "caml_alloc_boxed" according to the default
+representation of unboxable types in the current version of OCaml.
+\end{itemize}
+
+\subsubsection{Low-level interface}
+
+The following functions are slightly more efficient than "caml_alloc", but
+also much more difficult to use.
+
+From the standpoint of the allocation functions, blocks are divided
+according to their size as zero-sized blocks, small blocks (with size
+less than or equal to \verb"Max_young_wosize"), and large blocks (with
+size greater than \verb"Max_young_wosize"). The constant
+\verb"Max_young_wosize" is declared in the include file "mlvalues.h". It
+is guaranteed to be at least 64 (words), so that any block with
+constant size less than or equal to 64 can be assumed to be small. For
+blocks whose size is computed at run-time, the size must be compared
+against \verb"Max_young_wosize" to determine the correct allocation procedure.
+
+\begin{itemize}
+\item
+"caml_alloc_small("\var{n}", "\var{t}")" returns a fresh small block of size
+$n \leq \hbox{"Max_young_wosize"}$ words, with tag \var{t}.
+If this block is a structured block (i.e. if $t < \hbox{"No_scan_tag"}$), then
+the fields of the block (initially containing garbage) must be initialized
+with legal values (using direct assignment to the fields of the block)
+before the next allocation.
+\item
+"caml_alloc_shr("\var{n}", "\var{t}")" returns a fresh block of size
+\var{n}, with tag \var{t}.
+The size of the block can be greater than \verb"Max_young_wosize". (It
+can also be smaller, but in this case it is more efficient to call
+"caml_alloc_small" instead of "caml_alloc_shr".)
+If this block is a structured block (i.e. if $t < \hbox{"No_scan_tag"}$), then
+the fields of the block (initially containing garbage) must be initialized
+with legal values (using the "caml_initialize" function described below)
+before the next allocation.
+\end{itemize}
+
+\subsection{Raising exceptions} \label{s:c-exceptions}
+
+Two functions are provided to raise two standard exceptions:
+\begin{itemize}
+\item "caml_failwith("\var{s}")", where \var{s} is a null-terminated C string (with
+type \verb"char *"), raises exception "Failure" with argument \var{s}.
+\item "caml_invalid_argument("\var{s}")", where \var{s} is a null-terminated C
+string (with type \verb"char *"), raises exception "Invalid_argument"
+with argument \var{s}.
+\end{itemize}
+
+Raising arbitrary exceptions from C is more delicate: the
+exception identifier is dynamically allocated by the OCaml program, and
+therefore must be communicated to the C function using the
+registration facility described below in section~\ref{s:register-exn}.
+Once the exception identifier is recovered in C, the following
+functions actually raise the exception:
+\begin{itemize}
+\item "caml_raise_constant("\var{id}")" raises the exception \var{id} with
+no argument;
+\item "caml_raise_with_arg("\var{id}", "\var{v}")" raises the exception
+\var{id} with the OCaml value \var{v} as argument;
+\item "caml_raise_with_args("\var{id}", "\var{n}", "\var{v}")"
+raises the exception \var{id} with the OCaml values
+\var{v}"[0]", \ldots, \var{v}"["\var{n}"-1]" as arguments;
+\item "caml_raise_with_string("\var{id}", "\var{s}")", where \var{s} is a
+null-terminated C string, raises the exception \var{id} with a copy of
+the C string \var{s} as argument.
+\end{itemize}
+
+\section{Living in harmony with the garbage collector}
+\pdfsection{Living in harmony with the garbage collector}
+
+Unused blocks in the heap are automatically reclaimed by the garbage
+collector. This requires some cooperation from C code that
+manipulates heap-allocated blocks.
+
+\subsection{Simple interface}
+
+All the macros described in this section are declared in the
+"memory.h" header file.
+
+\begin{gcrule}
+A function that has parameters or local variables of type "value" must
+begin with a call to one of the "CAMLparam" macros and return with
+"CAMLreturn", "CAMLreturn0", or "CAMLreturnT". In particular, "CAMLlocal"
+and "CAMLxparam" can only be called \emph{after} "CAMLparam".
+\end{gcrule}
+
+There are six "CAMLparam" macros: "CAMLparam0" to "CAMLparam5", which
+take zero to five arguments respectively. If your function has no more
+than 5 parameters of type "value", use the corresponding macros
+with these parameters as arguments. If your function has more than 5
+parameters of type "value", use "CAMLparam5" with five of these
+parameters, and use one or more calls to the "CAMLxparam" macros for
+the remaining parameters ("CAMLxparam1" to "CAMLxparam5").
+
+The macros "CAMLreturn", "CAMLreturn0", and "CAMLreturnT" are used to
+replace the C
+keyword "return". Every occurrence of "return x" must be replaced by
+"CAMLreturn (x)" if "x" has type "value", or "CAMLreturnT (t, x)"
+(where "t" is the type of "x"); every occurrence of "return" without
+argument must be
+replaced by "CAMLreturn0". If your C function is a procedure (i.e. if
+it returns void), you must insert "CAMLreturn0" at the end (to replace
+C's implicit "return").
+
+\paragraph{Note:} some C compilers give bogus warnings about unused
+variables "caml__dummy_xxx" at each use of "CAMLparam" and
+"CAMLlocal". You should ignore them.
+
+\goodbreak
+
+Example:
+\begin{verbatim}
+void foo (value v1, value v2, value v3)
+{
+ CAMLparam3 (v1, v2, v3);
+ ...
+ CAMLreturn0;
+}
+\end{verbatim}
+
+\paragraph{Note:} if your function is a primitive with more than 5 arguments
+for use with the byte-code runtime, its arguments are not "value"s and
+must not be declared (they have types "value *" and "int").
+
+\begin{gcrule}
+Local variables of type "value" must be declared with one of the
+"CAMLlocal" macros. Arrays of "value"s are declared with
+"CAMLlocalN". These macros must be used at the beginning of the
+function, not in a nested block.
+\end{gcrule}
+
+The macros "CAMLlocal1" to "CAMLlocal5" declare and initialize one to
+five local variables of type "value". The variable names are given as
+arguments to the macros. "CAMLlocalN("\var{x}", "\var{n}")" declares
+and initializes a local variable of type "value ["\var{n}"]". You can
+use several calls to these macros if you have more than 5 local
+variables.
+
+Example:
+\begin{verbatim}
+value bar (value v1, value v2, value v3)
+{
+ CAMLparam3 (v1, v2, v3);
+ CAMLlocal1 (result);
+ result = caml_alloc (3, 0);
+ ...
+ CAMLreturn (result);
+}
+\end{verbatim}
+
+\begin{gcrule}
+Assignments to the fields of structured blocks must be done with the
+"Store_field" macro (for normal blocks) or "Store_double_field" macro
+(for arrays and records of floating-point numbers). Other assignments
+must not use "Store_field" nor "Store_double_field".
+\end{gcrule}
+
+"Store_field ("\var{b}", "\var{n}", "\var{v}")" stores the value
+\var{v} in the field number \var{n} of value \var{b}, which must be a
+block (i.e. "Is_block("\var{b}")" must be true).
+
+Example:
+\begin{verbatim}
+value bar (value v1, value v2, value v3)
+{
+ CAMLparam3 (v1, v2, v3);
+ CAMLlocal1 (result);
+ result = caml_alloc (3, 0);
+ Store_field (result, 0, v1);
+ Store_field (result, 1, v2);
+ Store_field (result, 2, v3);
+ CAMLreturn (result);
+}
+\end{verbatim}
+
+\paragraph{Warning:} The first argument of "Store_field" and
+"Store_double_field" must be a variable declared by "CAMLparam*" or
+a parameter declared by "CAMLlocal*" to ensure that a garbage
+collection triggered by the evaluation of the other arguments will not
+invalidate the first argument after it is computed.
+
+\paragraph{Use with CAMLlocalN:} Arrays of values declared using
+"CAMLlocalN" must not be written to using "Store_field".
+Use the normal C array syntax instead.
+
+\begin{gcrule} Global variables containing values must be registered
+with the garbage collector using the "caml_register_global_root" function.
+\end{gcrule}
+
+Registration of a global variable "v" is achieved by calling
+"caml_register_global_root(&v)" just before or just after a valid
+value is stored in "v" for the first time. You must not call any
+of the OCaml runtime functions or macros between registering and
+storing the value.
+
+A registered global variable "v" can be un-registered by calling
+"caml_remove_global_root(&v)".
+
+If the contents of the global variable "v" are seldom modified after
+registration, better performance can be achieved by calling
+"caml_register_generational_global_root(&v)" to register "v" (after
+its initialization with a valid "value", but before any allocation or
+call to the GC functions),
+and "caml_remove_generational_global_root(&v)" to un-register it. In
+this case, you must not modify the value of "v" directly, but you must
+use "caml_modify_generational_global_root(&v,x)" to set it to "x".
+The garbage collector takes advantage of the guarantee that "v" is not
+modified between calls to "caml_modify_generational_global_root" to scan it
+less often. This improves performance if the
+modifications of "v" happen less often than minor collections.
+
+\paragraph{Note:} The "CAML" macros use identifiers (local variables, type
+identifiers, structure tags) that start with "caml__". Do not use any
+identifier starting with "caml__" in your programs.
+
+\subsection{Low-level interface}
+
+% Il faudrait simplifier violemment ce qui suit.
+% En gros, dire quand on n'a pas besoin de declarer les variables
+% et dans quels cas on peut se passer de "Store_field".
+
+We now give the GC rules corresponding to the low-level allocation
+functions "caml_alloc_small" and "caml_alloc_shr". You can ignore those rules
+if you stick to the simplified allocation function "caml_alloc".
+
+\begin{gcrule} After a structured block (a block with tag less than
+"No_scan_tag") is allocated with the low-level functions, all fields
+of this block must be filled with well-formed values before the next
+allocation operation. If the block has been allocated with
+"caml_alloc_small", filling is performed by direct assignment to the fields
+of the block:
+\begin{alltt}
+ Field(\var{v}, \var{n}) = \nth{v}{n};
+\end{alltt}
+If the block has been allocated with "caml_alloc_shr", filling is performed
+through the "caml_initialize" function:
+\begin{alltt}
+ caml_initialize(&Field(\var{v}, \var{n}), \nth{v}{n});
+\end{alltt}
+\end{gcrule}
+
+The next allocation can trigger a garbage collection. The garbage
+collector assumes that all structured blocks contain well-formed
+values. Newly created blocks contain random data, which generally do
+not represent well-formed values.
+
+If you really need to allocate before the fields can receive their
+final value, first initialize with a constant value (e.g.
+"Val_unit"), then allocate, then modify the fields with the correct
+value (see rule~6).
+
+%% \begin{gcrule} Local variables and function parameters containing
+%% values must be registered with the garbage collector (using the
+%% "Begin_roots" and "End_roots" macros), if they are to survive a call
+%% to an allocation function.
+%% \end{gcrule}
+%%
+%% Registration is performed with the "Begin_roots" set of macros.
+%% "Begin_roots1("\var{v}")" registers variable \var{v} with the garbage
+%% collector. Generally, \var{v} will be a local variable or a
+%% parameter of your function. It must be initialized to a valid value
+%% (e.g. "Val_unit") before the first allocation. Likewise,
+%% "Begin_roots2", \ldots, "Begin_roots5"
+%% let you register up to 5 variables at the same time. "Begin_root" is
+%% the same as "Begin_roots1". "Begin_roots_block("\var{ptr}","\var{size}")"
+%% allows you to register an array of roots. \var{ptr} is a pointer to
+%% the first element, and \var{size} is the number of elements in the
+%% array.
+%%
+%% Once registered, each of your variables (or array element) has the
+%% following properties: if it points to a heap-allocated block, this
+%% block (and its contents) will not be reclaimed; moreover, if this
+%% block is relocated by the garbage collector, the variable is updated
+%% to point to the new location for the block.
+%%
+%% Each of the "Begin_roots" macros open a C block that must be closed
+%% with a matching "End_roots" at the same nesting level. The block must
+%% be exited normally (i.e. not with "return" or "goto"). However, the
+%% roots are automatically un-registered if an OCaml exception is raised,
+%% so you can exit the block with "failwith", "invalid_argument", or one
+%% of the "raise" functions.
+%%
+%% {\bf Note:} The "Begin_roots" macros use a local variable and a
+%% structure tag named "caml__roots_block". Do not use this identifier
+%% in your programs.
+
+\begin{gcrule} Direct assignment to a field of a block, as in
+\begin{alltt}
+ Field(\var{v}, \var{n}) = \var{w};
+\end{alltt}
+is safe only if \var{v} is a block newly allocated by "caml_alloc_small";
+that is, if no allocation took place between the
+allocation of \var{v} and the assignment to the field. In all other cases,
+never assign directly. If the block has just been allocated by "caml_alloc_shr",
+use "caml_initialize" to assign a value to a field for the first time:
+\begin{alltt}
+ caml_initialize(&Field(\var{v}, \var{n}), \var{w});
+\end{alltt}
+Otherwise, you are updating a field that previously contained a
+well-formed value; then, call the "caml_modify" function:
+\begin{alltt}
+ caml_modify(&Field(\var{v}, \var{n}), \var{w});
+\end{alltt}
+\end{gcrule}
+
+To illustrate the rules above, here is a C function that builds and
+returns a list containing the two integers given as parameters.
+First, we write it using the simplified allocation functions:
+\begin{verbatim}
+value alloc_list_int(int i1, int i2)
+{
+ CAMLparam0 ();
+ CAMLlocal2 (result, r);
+
+ r = caml_alloc(2, 0); /* Allocate a cons cell */
+ Store_field(r, 0, Val_int(i2)); /* car = the integer i2 */
+ Store_field(r, 1, Val_int(0)); /* cdr = the empty list [] */
+ result = caml_alloc(2, 0); /* Allocate the other cons cell */
+ Store_field(result, 0, Val_int(i1)); /* car = the integer i1 */
+ Store_field(result, 1, r); /* cdr = the first cons cell */
+ CAMLreturn (result);
+}
+\end{verbatim}
+Here, the registering of "result" is not strictly needed, because no
+allocation takes place after it gets its value, but it's easier and
+safer to simply register all the local variables that have type "value".
+
+Here is the same function written using the low-level allocation
+functions. We notice that the cons cells are small blocks and can be
+allocated with "caml_alloc_small", and filled by direct assignments on
+their fields.
+\begin{verbatim}
+value alloc_list_int(int i1, int i2)
+{
+ CAMLparam0 ();
+ CAMLlocal2 (result, r);
+
+ r = caml_alloc_small(2, 0); /* Allocate a cons cell */
+ Field(r, 0) = Val_int(i2); /* car = the integer i2 */
+ Field(r, 1) = Val_int(0); /* cdr = the empty list [] */
+ result = caml_alloc_small(2, 0); /* Allocate the other cons cell */
+ Field(result, 0) = Val_int(i1); /* car = the integer i1 */
+ Field(result, 1) = r; /* cdr = the first cons cell */
+ CAMLreturn (result);
+}
+\end{verbatim}
+In the two examples above, the list is built bottom-up. Here is an
+alternate way, that proceeds top-down. It is less efficient, but
+illustrates the use of "caml_modify".
+\begin{verbatim}
+value alloc_list_int(int i1, int i2)
+{
+ CAMLparam0 ();
+ CAMLlocal2 (tail, r);
+
+ r = caml_alloc_small(2, 0); /* Allocate a cons cell */
+ Field(r, 0) = Val_int(i1); /* car = the integer i1 */
+ Field(r, 1) = Val_int(0); /* A dummy value
+ tail = caml_alloc_small(2, 0); /* Allocate the other cons cell */
+ Field(tail, 0) = Val_int(i2); /* car = the integer i2 */
+ Field(tail, 1) = Val_int(0); /* cdr = the empty list [] */
+ caml_modify(&Field(r, 1), tail); /* cdr of the result = tail */
+ CAMLreturn (r);
+}
+\end{verbatim}
+It would be incorrect to perform
+"Field(r, 1) = tail" directly, because the allocation of "tail"
+has taken place since "r" was allocated.
+
+
+\section{A complete example}
+\pdfsection{A complete example}
+
+This section outlines how the functions from the Unix "curses" library
+can be made available to OCaml programs. First of all, here is
+the interface "curses.ml" that declares the "curses" primitives and
+data types:
+\begin{verbatim}
+(* File curses.ml -- declaration of primitives and data types *)
+type window (* The type "window" remains abstract *)
+external initscr: unit -> window = "caml_curses_initscr"
+external endwin: unit -> unit = "caml_curses_endwin"
+external refresh: unit -> unit = "caml_curses_refresh"
+external wrefresh : window -> unit = "caml_curses_wrefresh"
+external newwin: int -> int -> int -> int -> window = "caml_curses_newwin"
+external addch: char -> unit = "caml_curses_addch"
+external mvwaddch: window -> int -> int -> char -> unit = "caml_curses_mvwaddch"
+external addstr: string -> unit = "caml_curses_addstr"
+external mvwaddstr: window -> int -> int -> string -> unit
+ = "caml_curses_mvwaddstr"
+(* lots more omitted *)
+\end{verbatim}
+To compile this interface:
+\begin{verbatim}
+ ocamlc -c curses.ml
+\end{verbatim}
+
+To implement these functions, we just have to provide the stub code;
+the core functions are already implemented in the "curses" library.
+The stub code file, "curses_stubs.c", looks like this:
+\begin{verbatim}
+/* File curses_stubs.c -- stub code for curses */
+#include <curses.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+
+/* Encapsulation of opaque window handles (of type WINDOW *)
+ as OCaml custom blocks. */
+
+static struct custom_operations curses_window_ops = {
+ "fr.inria.caml.curses_windows",
+ custom_finalize_default,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default,
+ custom_compare_ext_default
+};
+
+/* Accessing the WINDOW * part of an OCaml custom block */
+#define Window_val(v) (*((WINDOW **) Data_custom_val(v)))
+
+/* Allocating an OCaml custom block to hold the given WINDOW * */
+static value alloc_window(WINDOW * w)
+{
+ value v = alloc_custom(&curses_window_ops, sizeof(WINDOW *), 0, 1);
+ Window_val(v) = w;
+ return v;
+}
+
+value caml_curses_initscr(value unit)
+{
+ CAMLparam1 (unit);
+ CAMLreturn (alloc_window(initscr()));
+}
+
+value caml_curses_endwin(value unit)
+{
+ CAMLparam1 (unit);
+ endwin();
+ CAMLreturn (Val_unit);
+}
+
+value caml_curses_refresh(value unit)
+{
+ CAMLparam1 (unit);
+ refresh();
+ CAMLreturn (Val_unit);
+}
+
+value caml_curses_wrefresh(value win)
+{
+ CAMLparam1 (win);
+ wrefresh(Window_val(win));
+ CAMLreturn (Val_unit);
+}
+
+value caml_curses_newwin(value nlines, value ncols, value x0, value y0)
+{
+ CAMLparam4 (nlines, ncols, x0, y0);
+ CAMLreturn (alloc_window(newwin(Int_val(nlines), Int_val(ncols),
+ Int_val(x0), Int_val(y0))));
+}
+
+value caml_curses_addch(value c)
+{
+ CAMLparam1 (c);
+ addch(Int_val(c)); /* Characters are encoded like integers */
+ CAMLreturn (Val_unit);
+}
+
+value caml_curses_mvwaddch(value win, value x, value y, value c)
+{
+ CAMLparam4 (win, x, y, c);
+ mvwaddch(Window_val(win), Int_val(x), Int_val(y), Int_val(c));
+ CAMLreturn (Val_unit);
+}
+
+value caml_curses_addstr(value s)
+{
+ CAMLparam1 (s);
+ addstr(String_val(s));
+ CAMLreturn (Val_unit);
+}
+
+value caml_curses_mvwaddstr(value win, value x, value y, value s)
+{
+ CAMLparam4 (win, x, y, s);
+ mvwaddstr(Window_val(win), Int_val(x), Int_val(y), String_val(s));
+ CAMLreturn (Val_unit);
+}
+
+/* This goes on for pages. */
+\end{verbatim}
+
+The file "curses_stubs.c" can be compiled with:
+\begin{verbatim}
+ cc -c -I`ocamlc -where` curses_stubs.c
+\end{verbatim}
+or, even simpler,
+\begin{verbatim}
+ ocamlc -c curses_stubs.c
+\end{verbatim}
+(When passed a ".c" file, the "ocamlc" command simply calls the C
+compiler on that file, with the right "-I" option.)
+
+Now, here is a sample OCaml program "prog.ml" that uses the "curses"
+module:
+\begin{verbatim}
+(* File prog.ml -- main program using curses *)
+open Curses;;
+let main_window = initscr () in
+let small_window = newwin 10 5 20 10 in
+ mvwaddstr main_window 10 2 "Hello";
+ mvwaddstr small_window 4 3 "world";
+ refresh();
+ Unix.sleep 5;
+ endwin()
+\end{verbatim}
+To compile and link this program, run:
+\begin{verbatim}
+ ocamlc -custom -o prog unix.cma curses.cmo prog.ml curses_stubs.o -cclib -lcurses
+\end{verbatim}
+(On some machines, you may need to put
+"-cclib -lcurses -cclib -ltermcap" or "-cclib -ltermcap"
+instead of "-cclib -lcurses".)
+
+%% Note by Damien: when I launch the program, it only displays "Hello"
+%% and not "world". Why?
+
+\section{Advanced topic: callbacks from C to OCaml} \label{s:callback}
+\pdfsection{Advanced topic: callbacks from C to OCaml}
+
+So far, we have described how to call C functions from OCaml. In this
+section, we show how C functions can call OCaml functions, either as
+callbacks (OCaml calls C which calls OCaml), or with the main program
+written in C.
+
+\subsection{Applying OCaml closures from C} \label{s:callbacks}
+
+C functions can apply OCaml function values (closures) to OCaml values.
+The following functions are provided to perform the applications:
+\begin{itemize}
+\item "caml_callback("\var{f, a}")" applies the functional value \var{f} to
+the value \var{a} and returns the value returned by~\var{f}.
+\item "caml_callback2("\var{f, a, b}")" applies the functional value \var{f}
+(which is assumed to be a curried OCaml function with two arguments) to
+\var{a} and \var{b}.
+\item "caml_callback3("\var{f, a, b, c}")" applies the functional value \var{f}
+(a curried OCaml function with three arguments) to \var{a}, \var{b} and \var{c}.
+\item "caml_callbackN("\var{f, n, args}")" applies the functional value \var{f}
+to the \var{n} arguments contained in the array of values \var{args}.
+\end{itemize}
+If the function \var{f} does not return, but raises an exception that
+escapes the scope of the application, then this exception is
+propagated to the next enclosing OCaml code, skipping over the C
+code. That is, if an OCaml function \var{f} calls a C function \var{g} that
+calls back an OCaml function \var{h} that raises a stray exception, then the
+execution of \var{g} is interrupted and the exception is propagated back
+into \var{f}.
+
+If the C code wishes to catch exceptions escaping the OCaml function,
+it can use the functions "caml_callback_exn", "caml_callback2_exn",
+"caml_callback3_exn", "caml_callbackN_exn". These functions take the same
+arguments as their non-"_exn" counterparts, but catch escaping
+exceptions and return them to the C code. The return value \var{v} of the
+"caml_callback*_exn" functions must be tested with the macro
+"Is_exception_result("\var{v}")". If the macro returns ``false'', no
+exception occured, and \var{v} is the value returned by the OCaml
+function. If "Is_exception_result("\var{v}")" returns ``true'',
+an exception escaped, and its value (the exception descriptor) can be
+recovered using "Extract_exception("\var{v}")".
+
+\paragraph{Warning:} If the OCaml function returned with an exception,
+"Extract_exception" should be applied to the exception result prior
+to calling a function that may trigger garbage collection.
+Otherwise, if \var{v} is reachable during garbage collection, the runtime
+can crash since \var{v} does not contain a valid value.
+
+Example:
+\begin{verbatim}
+ value call_caml_f_ex(value closure, value arg)
+ {
+ CAMLparam2(closure, arg);
+ CAMLlocal2(res, tmp);
+ res = caml_callback_exn(closure, arg);
+ if(Is_exception_result(res)) {
+ res = Extract_exception(res);
+ tmp = caml_alloc(3, 0); /* Safe to allocate: res contains valid value. */
+ ...
+ }
+ CAMLreturn (res);
+ }
+\end{verbatim}
+
+\subsection{Obtaining or registering OCaml closures for use in C functions}
+
+There are two ways to obtain OCaml function values (closures) to
+be passed to the "callback" functions described above. One way is to
+pass the OCaml function as an argument to a primitive function. For
+example, if the OCaml code contains the declaration
+\begin{verbatim}
+ external apply : ('a -> 'b) -> 'a -> 'b = "caml_apply"
+\end{verbatim}
+the corresponding C stub can be written as follows:
+\begin{verbatim}
+ CAMLprim value caml_apply(value vf, value vx)
+ {
+ CAMLparam2(vf, vx);
+ CAMLlocal1(vy);
+ vy = caml_callback(vf, vx);
+ CAMLreturn(vy);
+ }
+\end{verbatim}
+
+Another possibility is to use the registration mechanism provided by
+OCaml. This registration mechanism enables OCaml code to register
+OCaml functions under some global name, and C code to retrieve the
+corresponding closure by this global name.
+
+On the OCaml side, registration is performed by evaluating
+"Callback.register" \var{n} \var{v}. Here, \var{n} is the global name
+(an arbitrary string) and \var{v} the OCaml value. For instance:
+\begin{verbatim}
+ let f x = print_string "f is applied to "; print_int x; print_newline()
+ let _ = Callback.register "test function" f
+\end{verbatim}
+
+On the C side, a pointer to the value registered under name \var{n} is
+obtained by calling "caml_named_value("\var{n}")". The returned
+pointer must then be dereferenced to recover the actual OCaml value.
+If no value is registered under the name \var{n}, the null pointer is
+returned. For example, here is a C wrapper that calls the OCaml function "f"
+above:
+\begin{verbatim}
+ void call_caml_f(int arg)
+ {
+ caml_callback(*caml_named_value("test function"), Val_int(arg));
+ }
+\end{verbatim}
+
+The pointer returned by "caml_named_value" is constant and can safely
+be cached in a C variable to avoid repeated name lookups. On the other
+hand, the value pointed to can change during garbage collection and
+must always be recomputed at the point of use. Here is a more
+efficient variant of "call_caml_f" above that calls "caml_named_value"
+only once:
+\begin{verbatim}
+ void call_caml_f(int arg)
+ {
+ static value * closure_f = NULL;
+ if (closure_f == NULL) {
+ /* First time around, look up by name */
+ closure_f = caml_named_value("test function");
+ }
+ caml_callback(*closure_f, Val_int(arg));
+ }
+\end{verbatim}
+
+\subsection{Registering OCaml exceptions for use in C functions} \label{s:register-exn}
+
+The registration mechanism described above can also be used to
+communicate exception identifiers from OCaml to C. The OCaml code
+registers the exception by evaluating
+"Callback.register_exception" \var{n} \var{exn}, where \var{n} is an
+arbitrary name and \var{exn} is an exception value of the
+exception to register. For example:
+\begin{verbatim}
+ exception Error of string
+ let _ = Callback.register_exception "test exception" (Error "any string")
+\end{verbatim}
+The C code can then recover the exception identifier using
+"caml_named_value" and pass it as first argument to the functions
+"raise_constant", "raise_with_arg", and "raise_with_string" (described
+in section~\ref{s:c-exceptions}) to actually raise the exception. For
+example, here is a C function that raises the "Error" exception with
+the given argument:
+\begin{verbatim}
+ void raise_error(char * msg)
+ {
+ caml_raise_with_string(*caml_named_value("test exception"), msg);
+ }
+\end{verbatim}
+
+\subsection{Main program in C} \label{s:main-c}
+
+In normal operation, a mixed OCaml/C program starts by executing the
+OCaml initialization code, which then may proceed to call C
+functions. We say that the main program is the OCaml code. In some
+applications, it is desirable that the C code plays the role of the
+main program, calling OCaml functions when needed. This can be achieved as
+follows:
+\begin{itemize}
+\item The C part of the program must provide a "main" function,
+which will override the default "main" function provided by the OCaml
+runtime system. Execution will start in the user-defined "main" function
+just like for a regular C program.
+
+\item At some point, the C code must call "caml_main(argv)" to
+initialize the OCaml code. The "argv" argument is a C array of strings
+(type "char **"), terminated with a "NULL" pointer,
+which represents the command-line arguments, as
+passed as second argument to "main". The OCaml array "Sys.argv" will
+be initialized from this parameter. For the bytecode compiler,
+"argv[0]" and "argv[1]" are also consulted to find the file containing
+the bytecode.
+
+\item The call to "caml_main" initializes the OCaml runtime system,
+loads the bytecode (in the case of the bytecode compiler), and
+executes the initialization code of the OCaml program. Typically, this
+initialization code registers callback functions using "Callback.register".
+Once the OCaml initialization code is complete, control returns to the
+C code that called "caml_main".
+
+\item The C code can then invoke OCaml functions using the callback
+mechanism (see section~\ref{s:callbacks}).
+\end{itemize}
+
+\subsection{Embedding the OCaml code in the C code} \label{s:embedded-code}
+
+The bytecode compiler in custom runtime mode ("ocamlc -custom")
+normally appends the bytecode to the executable file containing the
+custom runtime. This has two consequences. First, the final linking
+step must be performed by "ocamlc". Second, the OCaml runtime library
+must be able to find the name of the executable file from the
+command-line arguments. When using "caml_main(argv)" as in
+section~\ref{s:main-c}, this means that "argv[0]" or "argv[1]" must
+contain the executable file name.
+
+An alternative is to embed the bytecode in the C code. The
+"-output-obj" option to "ocamlc" is provided for this purpose. It
+causes the "ocamlc" compiler to output a C object file (".o" file,
+".obj" under Windows) containing the bytecode for the OCaml part of the
+program, as well as a "caml_startup" function. The C object file
+produced by "ocamlc -output-obj" can then be linked with C code using
+the standard C compiler, or stored in a C library.
+
+The "caml_startup" function must be called from the main C program in
+order to initialize the OCaml runtime and execute the OCaml
+initialization code. Just like "caml_main", it takes one "argv"
+parameter containing the command-line parameters. Unlike "caml_main",
+this "argv" parameter is used only to initialize "Sys.argv", but not
+for finding the name of the executable file.
+
+The "caml_startup" function calls the uncaught exception handler (or
+enters the debugger, if running under ocamldebug) if an exception escapes
+from a top-level module initialiser. Such exceptions may be caught in the
+C code by instead using the "caml_startup_exn" function and testing the result
+using {\tt Is_exception_result} (followed by {\tt Extract_exception} if
+appropriate).
+
+The "-output-obj" option can also be used to obtain the C source file.
+More interestingly, the same option can also produce directly a shared
+library (".so" file, ".dll" under Windows) that contains the OCaml
+code, the OCaml runtime system and any other static C code given to
+"ocamlc" (".o", ".a", respectively, ".obj", ".lib"). This use of
+"-output-obj" is very similar to a normal linking step, but instead of
+producing a main program that automatically runs the OCaml code, it
+produces a shared library that can run the OCaml code on demand. The
+three possible behaviors of "-output-obj" are selected according
+to the extension of the resulting file (given with "-o").
+
+The native-code compiler "ocamlopt" also supports the "-output-obj"
+option, causing it to output a C object file or a shared library
+containing the native code for all OCaml modules on the command-line,
+as well as the OCaml startup code. Initialization is performed by
+calling "caml_startup" (or "caml_startup_exn") as in the case of the
+bytecode compiler.
+
+For the final linking phase, in addition to the object file produced
+by "-output-obj", you will have to provide the OCaml runtime
+library ("libcamlrun.a" for bytecode, "libasmrun.a" for native-code),
+as well as all C libraries that are required by the OCaml libraries
+used. For instance, assume the OCaml part of your program uses the
+Unix library. With "ocamlc", you should do:
+\begin{alltt}
+ ocamlc -output-obj -o camlcode.o unix.cma {\it{other}} .cmo {\it{and}} .cma {\it{files}}
+ cc -o myprog {\it{C objects and libraries}} \char92
+ camlcode.o -L`ocamlc -where` -lunix -lcamlrun
+\end{alltt}
+With "ocamlopt", you should do:
+\begin{alltt}
+ ocamlopt -output-obj -o camlcode.o unix.cmxa {\it{other}} .cmx {\it{and}} .cmxa {\it{files}}
+ cc -o myprog {\it{C objects and libraries}} \char92
+ camlcode.o -L`ocamlc -where` -lunix -lasmrun
+\end{alltt}
+
+% -- This seems completely wrong -- Damien
+% The shared libraries produced by "ocamlc -output-obj" or by "ocamlopt
+% -output-obj" already contains the OCaml runtime library as
+% well as all the needed C libraries.
+
+\paragraph{Warning:} On some ports, special options are required on the final
+linking phase that links together the object file produced by the
+"-output-obj" option and the remainder of the program. Those options
+are shown in the configuration file "config/Makefile" generated during
+compilation of OCaml, as the variable "LDFLAGS".
+\begin{itemize}
+\item Windows with the MSVC compiler: the object file produced by
+OCaml have been compiled with the "/MD" flag, and therefore
+all other object files linked with it should also be compiled with
+"/MD".
+\item other systems: you may have to add one or more of "-lcurses",
+"-lm", "-ldl", depending on your OS and C compiler.
+\end{itemize}
+
+\paragraph{Stack backtraces.} When OCaml bytecode produced by
+"ocamlc -g" is embedded in a C program, no debugging information is
+included, and therefore it is impossible to print stack backtraces on
+uncaught exceptions. This is not the case when native code produced
+by "ocamlopt -g" is embedded in a C program: stack backtrace
+information is available, but the backtrace mechanism needs to be
+turned on programmatically. This can be achieved from the OCaml side
+by calling "Printexc.record_backtrace true" in the initialization of
+one of the OCaml modules. This can also be achieved from the C side
+by calling "caml_record_backtrace(Val_int(1));" in the OCaml-C glue code.
+
+\paragraph{Unloading the runtime.}
+
+In case the shared library produced with "-output-obj" is to be loaded and
+unloaded repeatedly by a single process, care must be taken to unload the
+OCaml runtime explicitly, in order to avoid various system resource leaks.
+
+Since 4.05, "caml_shutdown" function can be used to shut the runtime down
+gracefully, which equals the following:
+\begin{itemize}
+\item Running the functions that were registered with "Pervasives.at_exit".
+\item Triggering finalization of allocated custom blocks (see
+section~\ref{s:custom}). For example, "Pervasives.in_channel" and
+"Pervasives.out_channel" are represented by custom blocks that enclose file
+descriptors, which are to be released.
+\item Unloading the dependent shared libraries that were loaded by the runtime,
+including "dynlink" plugins.
+\item Freeing the memory blocks that were allocated by the runtime with
+"malloc". Inside C primitives, it is advised to use "caml_stat_*" functions
+from "memory.h" for managing static (that is, non-moving) blocks of heap
+memory, as all the blocks allocated with these functions are automatically
+freed by "caml_shutdown". For ensuring compatibility with legacy C stubs that
+have used "caml_stat_*" incorrectly, this behaviour is only enabled if the
+runtime is started with a specialized "caml_startup_pooled" function.
+\end{itemize}
+
+As a shared library may have several clients simultaneously, it is made for
+convenience that "caml_startup" (and "caml_startup_pooled") may be called
+multiple times, given that each such call is paired with a corresponding call
+to "caml_shutdown" (in a nested fashion). The runtime will be unloaded once
+there are no outstanding calls to "caml_startup".
+
+Once a runtime is unloaded, it cannot be started up again without reloading the
+shared library and reinitializing its static data. Therefore, at the moment, the
+facility is only useful for building reloadable shared libraries.
+
+
+\section{Advanced example with callbacks}
+\pdfsection{Advanced example with callbacks}
+
+This section illustrates the callback facilities described in
+section~\ref{s:callback}. We are going to package some OCaml functions
+in such a way that they can be linked with C code and called from C
+just like any C functions. The OCaml functions are defined in the
+following "mod.ml" OCaml source:
+
+\begin{verbatim}
+(* File mod.ml -- some "useful" OCaml functions *)
+
+let rec fib n = if n < 2 then 1 else fib(n-1) + fib(n-2)
+
+let format_result n = Printf.sprintf "Result is: %d\n" n
+
+(* Export those two functions to C *)
+
+let _ = Callback.register "fib" fib
+let _ = Callback.register "format_result" format_result
+\end{verbatim}
+
+Here is the C stub code for calling these functions from C:
+
+\begin{verbatim}
+/* File modwrap.c -- wrappers around the OCaml functions */
+
+#include <stdio.h>
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/callback.h>
+
+int fib(int n)
+{
+ static value * fib_closure = NULL;
+ if (fib_closure == NULL) fib_closure = caml_named_value("fib");
+ return Int_val(caml_callback(*fib_closure, Val_int(n)));
+}
+
+char * format_result(int n)
+{
+ static value * format_result_closure = NULL;
+ if (format_result_closure == NULL)
+ format_result_closure = caml_named_value("format_result");
+ return strdup(String_val(caml_callback(*format_result_closure, Val_int(n))));
+ /* We copy the C string returned by String_val to the C heap
+ so that it remains valid after garbage collection. */
+}
+\end{verbatim}
+
+We now compile the OCaml code to a C object file and put it in a C
+library along with the stub code in "modwrap.c" and the OCaml runtime system:
+\begin{verbatim}
+ ocamlc -custom -output-obj -o modcaml.o mod.ml
+ ocamlc -c modwrap.c
+ cp `ocamlc -where`/libcamlrun.a mod.a && chmod +w mod.a
+ ar r mod.a modcaml.o modwrap.o
+\end{verbatim}
+(One can also use "ocamlopt -output-obj" instead of "ocamlc -custom
+-output-obj". In this case, replace "libcamlrun.a" (the bytecode
+runtime library) by "libasmrun.a" (the native-code runtime library).)
+
+Now, we can use the two functions "fib" and "format_result" in any C
+program, just like regular C functions. Just remember to call
+"caml_startup" (or "caml_startup_exn") once before.
+
+\begin{verbatim}
+/* File main.c -- a sample client for the OCaml functions */
+
+#include <stdio.h>
+#include <caml/callback.h>
+
+extern int fib(int n);
+extern char * format_result(int n);
+
+int main(int argc, char ** argv)
+{
+ int result;
+
+ /* Initialize OCaml code */
+ caml_startup(argv);
+ /* Do some computation */
+ result = fib(10);
+ printf("fib(10) = %s\n", format_result(result));
+ return 0;
+}
+\end{verbatim}
+
+To build the whole program, just invoke the C compiler as follows:
+\begin{verbatim}
+ cc -o prog -I `ocamlc -where` main.c mod.a -lcurses
+\end{verbatim}
+(On some machines, you may need to put "-ltermcap" or
+"-lcurses -ltermcap" instead of "-lcurses".)
+
+\section{Advanced topic: custom blocks} \label{s:custom}
+\pdfsection{Advanced topic: custom blocks}
+
+Blocks with tag "Custom_tag" contain both arbitrary user data and a
+pointer to a C struct, with type "struct custom_operations", that
+associates user-provided finalization, comparison, hashing,
+serialization and deserialization functions to this block.
+
+\subsection{The "struct custom_operations"}
+
+The "struct custom_operations" is defined in "<caml/custom.h>" and
+contains the following fields:
+\begin{itemize}
+\item "char *identifier" \\
+A zero-terminated character string serving as an identifier for
+serialization and deserialization operations.
+
+\item "void (*finalize)(value v)" \\
+The "finalize" field contains a pointer to a C function that is called
+when the block becomes unreachable and is about to be reclaimed.
+The block is passed as first argument to the function.
+The "finalize" field can also be "custom_finalize_default" to indicate that no
+finalization function is associated with the block.
+
+\item "int (*compare)(value v1, value v2)" \\
+The "compare" field contains a pointer to a C function that is
+called whenever two custom blocks are compared using OCaml's generic
+comparison operators ("=", "<>", "<=", ">=", "<", ">" and
+"compare"). The C function should return 0 if the data contained in
+the two blocks are structurally equal, a negative integer if the data
+from the first block is less than the data from the second block, and
+a positive integer if the data from the first block is greater than
+the data from the second block.
+
+The "compare" field can be set to "custom_compare_default"; this
+default comparison function simply raises "Failure".
+
+\item "int (*compare_ext)(value v1, value v2)" \\
+(Since 3.12.1)
+The "compare_ext" field contains a pointer to a C function that is
+called whenever one custom block and one unboxed integer are compared using OCaml's generic
+comparison operators ("=", "<>", "<=", ">=", "<", ">" and
+"compare"). As in the case of the "compare" field, the C function
+should return 0 if the two arguments are structurally equal, a
+negative integer if the first argument compares less than the second
+argument, and a positive integer if the first argument compares
+greater than the second argument.
+
+The "compare_ext" field can be set to "custom_compare_ext_default"; this
+default comparison function simply raises "Failure".
+
+\item "intnat (*hash)(value v)" \\
+The "hash" field contains a pointer to a C function that is called
+whenever OCaml's generic hash operator (see module "Hashtbl") is
+applied to a custom block. The C function can return an arbitrary
+integer representing the hash value of the data contained in the
+given custom block. The hash value must be compatible with the
+"compare" function, in the sense that two structurally equal data
+(that is, two custom blocks for which "compare" returns 0) must have
+the same hash value.
+
+The "hash" field can be set to "custom_hash_default", in which case
+the custom block is ignored during hash computation.
+
+\item "void (*serialize)(value v, uintnat * wsize_32, uintnat * wsize_64)" \\
+The "serialize" field contains a pointer to a C function that is
+called whenever the custom block needs to be serialized (marshaled)
+using the OCaml functions "output_value" or "Marshal.to_...".
+For a custom block, those functions first write the identifier of the
+block (as given by the "identifier" field) to the output stream,
+then call the user-provided "serialize" function. That function is
+responsible for writing the data contained in the custom block, using
+the "serialize_..." functions defined in "<caml/intext.h>" and listed
+below. The user-provided "serialize" function must then store in its
+"wsize_32" and "wsize_64" parameters the sizes in bytes of the data
+part of the custom block on a 32-bit architecture and on a 64-bit
+architecture, respectively.
+
+The "serialize" field can be set to "custom_serialize_default",
+in which case the "Failure" exception is raised when attempting to
+serialize the custom block.
+
+\item "uintnat (*deserialize)(void * dst)" \\
+The "deserialize" field contains a pointer to a C function that is
+called whenever a custom block with identifier "identifier" needs to
+be deserialized (un-marshaled) using the OCaml functions "input_value"
+or "Marshal.from_...". This user-provided function is responsible for
+reading back the data written by the "serialize" operation, using the
+"deserialize_..." functions defined in "<caml/intext.h>" and listed
+below. It must then rebuild the data part of the custom block
+and store it at the pointer given as the "dst" argument. Finally, it
+returns the size in bytes of the data part of the custom block.
+This size must be identical to the "wsize_32" result of
+the "serialize" operation if the architecture is 32 bits, or
+"wsize_64" if the architecture is 64 bits.
+
+The "deserialize" field can be set to "custom_deserialize_default"
+to indicate that deserialization is not supported. In this case,
+do not register the "struct custom_operations" with the deserializer
+using "register_custom_operations" (see below).
+\end{itemize}
+
+Note: the "finalize", "compare", "hash", "serialize" and "deserialize"
+functions attached to custom block descriptors must never trigger a
+garbage collection. Within these functions, do not call any of the
+OCaml allocation functions, and do not perform a callback into OCaml
+code. Do not use "CAMLparam" to register the parameters to these
+functions, and do not use "CAMLreturn" to return the result.
+
+\subsection{Allocating custom blocks}
+
+Custom blocks must be allocated via the "caml_alloc_custom" function:
+\begin{center}
+"caml_alloc_custom("\var{ops}", "\var{size}", "\var{used}", "\var{max}")"
+\end{center}
+returns a fresh custom block, with room for \var{size} bytes of user
+data, and whose associated operations are given by \var{ops} (a
+pointer to a "struct custom_operations", usually statically allocated
+as a C global variable).
+
+The two parameters \var{used} and \var{max} are used to control the
+speed of garbage collection when the finalized object contains
+pointers to out-of-heap resources. Generally speaking, the
+OCaml incremental major collector adjusts its speed relative to the
+allocation rate of the program. The faster the program allocates, the
+harder the GC works in order to reclaim quickly unreachable blocks
+and avoid having large amount of ``floating garbage'' (unreferenced
+objects that the GC has not yet collected).
+
+Normally, the allocation rate is measured by counting the in-heap size
+of allocated blocks. However, it often happens that finalized
+objects contain pointers to out-of-heap memory blocks and other resources
+(such as file descriptors, X Windows bitmaps, etc.). For those
+blocks, the in-heap size of blocks is not a good measure of the
+quantity of resources allocated by the program.
+
+The two arguments \var{used} and \var{max} give the GC an idea of how
+much out-of-heap resources are consumed by the finalized block
+being allocated: you give the amount of resources allocated to this
+object as parameter \var{used}, and the maximum amount that you want
+to see in floating garbage as parameter \var{max}. The units are
+arbitrary: the GC cares only about the ratio $\var{used} / \var{max}$.
+
+For instance, if you are allocating a finalized block holding an X
+Windows bitmap of \var{w} by \var{h} pixels, and you'd rather not
+have more than 1 mega-pixels of unreclaimed bitmaps, specify
+$\var{used} = \var{w} * \var{h}$ and $\var{max} = 1000000$.
+
+Another way to describe the effect of the \var{used} and \var{max}
+parameters is in terms of full GC cycles. If you allocate many custom
+blocks with $\var{used} / \var{max} = 1 / \var{N}$, the GC will then do one
+full cycle (examining every object in the heap and calling
+finalization functions on those that are unreachable) every \var{N}
+allocations. For instance, if $\var{used} = 1$ and $\var{max} = 1000$,
+the GC will do one full cycle at least every 1000 allocations of
+custom blocks.
+
+If your finalized blocks contain no pointers to out-of-heap resources,
+or if the previous discussion made little sense to you, just take
+$\var{used} = 0$ and $\var{max} = 1$. But if you later find that the
+finalization functions are not called ``often enough'', consider
+increasing the $\var{used} / \var{max}$ ratio.
+
+\subsection{Accessing custom blocks}
+
+The data part of a custom block \var{v} can be
+accessed via the pointer "Data_custom_val("\var{v}")". This pointer
+has type "void *" and should be cast to the actual type of the data
+stored in the custom block.
+
+The contents of custom blocks are not scanned by the garbage
+collector, and must therefore not contain any pointer inside the OCaml
+heap. In other terms, never store an OCaml "value" in a custom block,
+and do not use "Field", "Store_field" nor "caml_modify" to access the data
+part of a custom block. Conversely, any C data structure (not
+containing heap pointers) can be stored in a custom block.
+
+\subsection{Writing custom serialization and deserialization functions}
+
+The following functions, defined in "<caml/intext.h>", are provided to
+write and read back the contents of custom blocks in a portable way.
+Those functions handle endianness conversions when e.g. data is
+written on a little-endian machine and read back on a big-endian machine.
+
+\begin{tableau}{|l|p{10cm}|}{Function}{Action}
+\entree{"caml_serialize_int_1"}{Write a 1-byte integer}
+\entree{"caml_serialize_int_2"}{Write a 2-byte integer}
+\entree{"caml_serialize_int_4"}{Write a 4-byte integer}
+\entree{"caml_serialize_int_8"}{Write a 8-byte integer}
+\entree{"caml_serialize_float_4"}{Write a 4-byte float}
+\entree{"caml_serialize_float_8"}{Write a 8-byte float}
+\entree{"caml_serialize_block_1"}{Write an array of 1-byte quantities}
+\entree{"caml_serialize_block_2"}{Write an array of 2-byte quantities}
+\entree{"caml_serialize_block_4"}{Write an array of 4-byte quantities}
+\entree{"caml_serialize_block_8"}{Write an array of 8-byte quantities}
+\entree{"caml_deserialize_uint_1"}{Read an unsigned 1-byte integer}
+\entree{"caml_deserialize_sint_1"}{Read a signed 1-byte integer}
+\entree{"caml_deserialize_uint_2"}{Read an unsigned 2-byte integer}
+\entree{"caml_deserialize_sint_2"}{Read a signed 2-byte integer}
+\entree{"caml_deserialize_uint_4"}{Read an unsigned 4-byte integer}
+\entree{"caml_deserialize_sint_4"}{Read a signed 4-byte integer}
+\entree{"caml_deserialize_uint_8"}{Read an unsigned 8-byte integer}
+\entree{"caml_deserialize_sint_8"}{Read a signed 8-byte integer}
+\entree{"caml_deserialize_float_4"}{Read a 4-byte float}
+\entree{"caml_deserialize_float_8"}{Read an 8-byte float}
+\entree{"caml_deserialize_block_1"}{Read an array of 1-byte quantities}
+\entree{"caml_deserialize_block_2"}{Read an array of 2-byte quantities}
+\entree{"caml_deserialize_block_4"}{Read an array of 4-byte quantities}
+\entree{"caml_deserialize_block_8"}{Read an array of 8-byte quantities}
+\entree{"caml_deserialize_error"}{Signal an error during deserialization;
+"input_value" or "Marshal.from_..." raise a "Failure" exception after
+cleaning up their internal data structures}
+\end{tableau}
+
+Serialization functions are attached to the custom blocks to which
+they apply. Obviously, deserialization functions cannot be attached
+this way, since the custom block does not exist yet when
+deserialization begins! Thus, the "struct custom_operations" that
+contain deserialization functions must be registered with the
+deserializer in advance, using the "register_custom_operations"
+function declared in "<caml/custom.h>". Deserialization proceeds by
+reading the identifier off the input stream, allocating a custom block
+of the size specified in the input stream, searching the registered
+"struct custom_operation" blocks for one with the same identifier, and
+calling its "deserialize" function to fill the data part of the custom block.
+
+\subsection{Choosing identifiers}
+
+Identifiers in "struct custom_operations" must be chosen carefully,
+since they must identify uniquely the data structure for serialization
+and deserialization operations. In particular, consider including a
+version number in the identifier; this way, the format of the data can
+be changed later, yet backward-compatible deserialisation functions
+can be provided.
+
+Identifiers starting with "_" (an underscore character) are reserved
+for the OCaml runtime system; do not use them for your custom
+data. We recommend to use a URL
+("http://mymachine.mydomain.com/mylibrary/version-number")
+or a Java-style package name
+("com.mydomain.mymachine.mylibrary.version-number")
+as identifiers, to minimize the risk of identifier collision.
+
+\subsection{Finalized blocks}
+
+Custom blocks generalize the finalized blocks that were present in
+OCaml prior to version 3.00. For backward compatibility, the
+format of custom blocks is compatible with that of finalized blocks,
+and the "alloc_final" function is still available to allocate a custom
+block with a given finalization function, but default comparison,
+hashing and serialization functions. "caml_alloc_final("\var{n}",
+"\var{f}", "\var{used}", "\var{max}")" returns a fresh custom block of
+size \var{n}+1 words, with finalization function \var{f}. The first
+word is reserved for storing the custom operations; the other
+\var{n} words are available for your data. The two parameters
+\var{used} and \var{max} are used to control the speed of garbage
+collection, as described for "caml_alloc_custom".
+
+\section{Advanced topic: Big arrays and the OCaml-C interface}
+\label{s:C-Bigarrays}
+
+This section explains how C stub code that interfaces C or Fortran
+code with OCaml code can use big arrays.
+
+\subsection{Include file}
+
+The include file "<caml/bigarray.h>" must be included in the C stub
+file. It declares the functions, constants and macros discussed
+below.
+
+\subsection{Accessing an OCaml bigarray from C or Fortran}
+
+If \var{v} is a OCaml "value" representing a big array, the expression
+"Caml_ba_data_val("\var{v}")" returns a pointer to the data part of the array.
+This pointer is of type "void *" and can be cast to the appropriate C
+type for the array (e.g. "double []", "char [][10]", etc).
+
+Various characteristics of the OCaml big array can be consulted from C
+as follows:
+\begin{tableau}{|l|l|}{C expression}{Returns}
+\entree{"Caml_ba_array_val("\var{v}")->num_dims"}{number of dimensions}
+\entree{"Caml_ba_array_val("\var{v}")->dim["\var{i}"]"}{\var{i}-th dimension}
+\entree{"Caml_ba_array_val("\var{v}")->flags & BIGARRAY_KIND_MASK"}{kind of array elements}
+\end{tableau}
+The kind of array elements is one of the following constants:
+\begin{tableau}{|l|l|}{Constant}{Element kind}
+\entree{"CAML_BA_FLOAT32"}{32-bit single-precision floats}
+\entree{"CAML_BA_FLOAT64"}{64-bit double-precision floats}
+\entree{"CAML_BA_SINT8"}{8-bit signed integers}
+\entree{"CAML_BA_UINT8"}{8-bit unsigned integers}
+\entree{"CAML_BA_SINT16"}{16-bit signed integers}
+\entree{"CAML_BA_UINT16"}{16-bit unsigned integers}
+\entree{"CAML_BA_INT32"}{32-bit signed integers}
+\entree{"CAML_BA_INT64"}{64-bit signed integers}
+\entree{"CAML_BA_CAML_INT"}{31- or 63-bit signed integers}
+\entree{"CAML_BA_NATIVE_INT"}{32- or 64-bit (platform-native) integers}
+\end{tableau}
+%
+The following example shows the passing of a two-dimensional big array
+to a C function and a Fortran function.
+\begin{verbatim}
+ extern void my_c_function(double * data, int dimx, int dimy);
+ extern void my_fortran_function_(double * data, int * dimx, int * dimy);
+
+ value caml_stub(value bigarray)
+ {
+ int dimx = Caml_ba_array_val(bigarray)->dim[0];
+ int dimy = Caml_ba_array_val(bigarray)->dim[1];
+ /* C passes scalar parameters by value */
+ my_c_function(Caml_ba_data_val(bigarray), dimx, dimy);
+ /* Fortran passes all parameters by reference */
+ my_fortran_function_(Caml_ba_data_val(bigarray), &dimx, &dimy);
+ return Val_unit;
+ }
+\end{verbatim}
+
+\subsection{Wrapping a C or Fortran array as an OCaml big array}
+
+A pointer \var{p} to an already-allocated C or Fortran array can be
+wrapped and returned to OCaml as a big array using the "caml_ba_alloc"
+or "caml_ba_alloc_dims" functions.
+\begin{itemize}
+\item
+"caml_ba_alloc("\var{kind} "|" \var{layout}, \var{numdims}, \var{p}, \var{dims}")"
+
+Return an OCaml big array wrapping the data pointed to by \var{p}.
+\var{kind} is the kind of array elements (one of the "CAML_BA_"
+kind constants above). \var{layout} is "CAML_BA_C_LAYOUT" for an
+array with C layout and "CAML_BA_FORTRAN_LAYOUT" for an array with
+Fortran layout. \var{numdims} is the number of dimensions in the
+array. \var{dims} is an array of \var{numdims} long integers, giving
+the sizes of the array in each dimension.
+
+\item
+"caml_ba_alloc_dims("\var{kind} "|" \var{layout}, \var{numdims},
+\var{p}, "(long) "\nth{dim}{1}, "(long) "\nth{dim}{2}, \ldots, "(long) "\nth{dim}{numdims}")"
+
+Same as "caml_ba_alloc", but the sizes of the array in each dimension
+are listed as extra arguments in the function call, rather than being
+passed as an array.
+\end{itemize}
+%
+The following example illustrates how statically-allocated C and
+Fortran arrays can be made available to OCaml.
+\begin{verbatim}
+ extern long my_c_array[100][200];
+ extern float my_fortran_array_[300][400];
+
+ value caml_get_c_array(value unit)
+ {
+ long dims[2];
+ dims[0] = 100; dims[1] = 200;
+ return caml_ba_alloc(CAML_BA_NATIVE_INT | CAML_BA_C_LAYOUT,
+ 2, my_c_array, dims);
+ }
+
+ value caml_get_fortran_array(value unit)
+ {
+ return caml_ba_alloc_dims(CAML_BA_FLOAT32 | CAML_BA_FORTRAN_LAYOUT,
+ 2, my_fortran_array_, 300L, 400L);
+ }
+\end{verbatim}
+
+\section{Advanced topic: cheaper C call}
+\label{s:C-cheaper-call}
+
+This section describe how to make calling C functions cheaper.
+
+{\bf Note:} this only applies to the native compiler. So whenever you
+use any of these methods, you have to provide an alternative byte-code
+stub that ignores all the special annotations.
+
+\subsection{Passing unboxed values}
+
+We said earlier that all OCaml objects are represented by the C type
+"value", and one has to use macros such as "Int_val" to decode data from
+the "value" type. It is however possible to tell the OCaml native-code
+compiler to do this for us and pass arguments unboxed to the C function.
+Similarly it is possible to tell OCaml to expect the result unboxed and box
+it for us.
+
+The motivation is that, by letting `ocamlopt` deal with boxing, it can
+often decide to suppress it entirely.
+
+For instance let's consider this example:
+
+\begin{verbatim}
+external foo : float -> float -> float = "foo"
+
+let f a b =
+ let len = Array.length a in
+ assert (Array.length b = len);
+ let res = Array.make len 0. in
+ for i = 0 to len - 1 do
+ res.(i) <- foo a.(i) b.(i)
+ done
+\end{verbatim}
+
+Float arrays are unboxed in OCaml, however the C function "foo" expect
+its arguments as boxed floats and returns a boxed float. Hence the
+OCaml compiler has no choice but to box "a.(i)" and "b.(i)" and unbox
+the result of "foo". This results in the allocation of "3 * len"
+temporary float values.
+
+Now if we annotate the arguments and result with "[\@unboxed]", the
+native-code compiler will be able to avoid all these allocations:
+
+\begin{verbatim}
+external foo
+ : (float [@unboxed])
+ -> (float [@unboxed])
+ -> (float [@unboxed])
+ = "foo_byte" "foo"
+\end{verbatim}
+
+In this case the C functions must look like:
+
+\begin{verbatim}
+CAMLprim double foo(double a, double b)
+{
+ ...
+}
+
+CAMLprim value foo_byte(value a, value b)
+{
+ return caml_copy_double(foo(Double_val(a), Double_val(b)))
+}
+\end{verbatim}
+
+For convenicence, when all arguments and the result are annotated with
+"[\@unboxed]", it is possible to put the attribute only once on the
+declaration itself. So we can also write instead:
+
+\begin{verbatim}
+external foo : float -> float -> float = "foo_byte" "foo" [@@unboxed]
+\end{verbatim}
+
+The following table summarize what OCaml types can be unboxed, and
+what C types should be used in correspondence:
+
+\begin{tableau}{|l|l|}{OCaml type}{C type}
+\entree{"float"}{"double"}
+\entree{"int32"}{"int32_t"}
+\entree{"int64"}{"int64_t"}
+\entree{"nativeint"}{"intnat"}
+\end{tableau}
+
+Similarly, it is possible to pass untagged OCaml integers between
+OCaml and C. This is done by annotating the arguments and/or result
+with "[\@untagged]":
+
+\begin{verbatim}
+external f : string -> (int [@untagged]) = "f_byte" "f"
+\end{verbatim}
+
+The corresponding C type must be "intnat".
+
+{\bf Note:} do not use the C "int" type in correspondence with "(int
+[\@untagged])". This is because they often differ in size.
+
+\subsection{Direct C call}
+
+In order to be able to run the garbage collector in the middle of
+a C function, the OCaml native-code compiler generates some bookkeeping
+code around C calls. Technically it wraps every C call with the C function
+"caml_c_call" which is part of the OCaml runtime.
+
+For small functions that are called repeatedly, this indirection can have
+a big impact on performances. However this is not needed if we know that
+the C function doesn't allocate and doesn't raise exceptions. We can
+instruct the OCaml native-code compiler of this fact by annotating the
+external declaration with the attribute "[\@\@noalloc]":
+
+\begin{verbatim}
+external bar : int -> int -> int = "foo" [@@noalloc]
+\end{verbatim}
+
+In this case calling "bar" from OCaml is as cheap as calling any other
+OCaml function, except for the fact that the OCaml compiler can't
+inline C functions...
+
+\subsection{Example: calling C library functions without indirection}
+
+Using these attributes, it is possible to call C library functions
+with no indirection. For instance many math functions are defined this
+way in the OCaml standard library:
+
+\begin{verbatim}
+external sqrt : float -> float = "caml_sqrt_float" "sqrt"
+ [@@unboxed] [@@noalloc]
+(** Square root. *)
+
+external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc]
+(** Exponential. *)
+
+external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc]
+(** Natural logarithm. *)
+\end{verbatim}
+
+\section{Advanced topic: multithreading}
+\label{s:C-multithreading}
+
+Using multiple threads (shared-memory concurrency) in a mixed OCaml/C
+application requires special precautions, which are described in this
+section.
+
+\subsection{Registering threads created from C}
+
+Callbacks from C to OCaml are possible only if the calling thread is
+known to the OCaml run-time system. Threads created from OCaml (through
+the "Thread.create" function of the system threads library) are
+automatically known to the run-time system. If the application
+creates additional threads from C and wishes to callback into OCaml
+code from these threads, it must first register them with the run-time
+system. The following functions are declared in the include file
+"<caml/threads.h>".
+
+\begin{itemize}
+\item
+"caml_c_thread_register()" registers the calling thread with the OCaml
+run-time system. Returns 1 on success, 0 on error. Registering an
+already-register thread does nothing and returns 0.
+\item
+"caml_c_thread_unregister()" must be called before the thread
+ terminates, to unregister it from the OCaml run-time system.
+Returns 1 on success, 0 on error. If the calling thread was not
+previously registered, does nothing and returns 0.
+\end{itemize}
+
+\subsection{Parallel execution of long-running C code}
+
+The OCaml run-time system is not reentrant: at any time, at most one
+thread can be executing OCaml code or C code that uses the OCaml
+run-time system. Technically, this is enforced by a ``master lock''
+that any thread must hold while executing such code.
+
+When OCaml calls the C code implementing a primitive, the master lock
+is held, therefore the C code has full access to the facilities of the
+run-time system. However, no other thread can execute OCaml code
+concurrently with the C code of the primitive.
+
+If a C primitive runs for a long time or performs potentially blocking
+input-output operations, it can explicitly release the master lock,
+enabling other OCaml threads to run concurrently with its operations.
+The C code must re-acquire the master lock before returning to OCaml.
+This is achieved with the following functions, declared in
+the include file "<caml/threads.h>".
+
+\begin{itemize}
+\item
+"caml_release_runtime_system()"
+The calling thread releases the master lock and other OCaml resources,
+enabling other threads to run OCaml code in parallel with the execution
+of the calling thread.
+\item
+"caml_acquire_runtime_system()"
+The calling thread re-acquires the master lock and other OCaml
+resources. It may block until no other thread uses the OCaml run-time
+system.
+\end{itemize}
+
+After "caml_release_runtime_system()" was called and until
+"caml_acquire_runtime_system()" is called, the C code must not access
+any OCaml data, nor call any function of the run-time system, nor call
+back into OCaml code. Consequently, arguments provided by OCaml to the
+C primitive must be copied into C data structures before calling
+"caml_release_runtime_system()", and results to be returned to OCaml
+must be encoded as OCaml values after "caml_acquire_runtime_system()"
+returns.
+
+Example: the following C primitive invokes "gethostbyname" to find the
+IP address of a host name. The "gethostbyname" function can block for
+a long time, so we choose to release the OCaml run-time system while it
+is running.
+\begin{verbatim}
+CAMLprim stub_gethostbyname(value vname)
+{
+ CAMLparam1 (vname);
+ CAMLlocal1 (vres);
+ struct hostent * h;
+ char * name;
+
+ /* Copy the string argument to a C string, allocated outside the
+ OCaml heap. */
+ name = caml_stat_strdup(String_val(vname));
+ /* Release the OCaml run-time system */
+ caml_release_runtime_system();
+ /* Resolve the name */
+ h = gethostbyname(name);
+ /* Free the copy of the string, which we might as well do before
+ acquiring the runtime system to benefit from parallelism. */
+ caml_stat_free(name);
+ /* Re-acquire the OCaml run-time system */
+ caml_acquire_runtime_system();
+ /* Encode the relevant fields of h as the OCaml value vres */
+ ... /* Omitted */
+ /* Return to OCaml */
+ CAMLreturn (vres);
+}
+\end{verbatim}
+
+Callbacks from C to OCaml must be performed while holding the master
+lock to the OCaml run-time system. This is naturally the case if the
+callback is performed by a C primitive that did not release the
+run-time system. If the C primitive released the run-time system
+previously, or the callback is performed from other C code that was
+not invoked from OCaml (e.g. an event loop in a GUI application), the
+run-time system must be acquired before the callback and released
+after:
+\begin{verbatim}
+ caml_acquire_runtime_system();
+ /* Resolve OCaml function vfun to be invoked */
+ /* Build OCaml argument varg to the callback */
+ vres = callback(vfun, varg);
+ /* Copy relevant parts of result vres to C data structures */
+ caml_release_runtime_system();
+\end{verbatim}
+
+Note: the "acquire" and "release" functions described above were
+introduced in OCaml 3.12. Older code uses the following historical
+names, declared in "<caml/signals.h>":
+\begin{itemize}
+\item "caml_enter_blocking_section" as an alias for
+ "caml_release_runtime_system"
+\item "caml_leave_blocking_section" as an alias for
+ "caml_acquire_runtime_system"
+\end{itemize}
+Intuition: a ``blocking section'' is a piece of C code that does not
+use the OCaml run-time system, typically a blocking input/output operation.
+
+\section{Advanced topic: interfacing with Windows Unicode APIs}
+\label{s:interfacing-windows-unicode-apis}
+
+This section contains some general guidelines for writing C stubs that use
+Windows Unicode APIs.
+
+{\bf Note:} This is an experimental feature of OCaml: the set of APIs below, as
+well as their exact semantics are not final and subject to change in future
+releases.
+
+The OCaml system under Windows can be configured at build time in one of two
+modes:
+
+\begin{itemize}
+
+\item {\bf legacy mode:} All path names, environment variables, command line
+arguments, etc. on the OCaml side are assumed to be encoded using the current
+8-bit code page of the system.
+
+\item {\bf Unicode mode:} All path names, environment variables, command line
+arguments, etc. on the OCaml side are assumed to be encoded using UTF-8.
+
+\end{itemize}
+
+In what follows, we say that a string has the \emph{OCaml encoding} if it is
+encoded in UTF-8 when in Unicode mode, in the current code page in legacy mode,
+or is an arbitrary string under Unix. A string has the \emph{platform encoding}
+if it is encoded in UTF-16 under Windows or is an arbitrary string under Unix.
+
+From the point of view of the writer of C stubs, the challenges of interacting
+with Windows Unicode APIs are twofold:
+
+\begin{itemize}
+
+\item The Windows API uses the UTF-16 encoding to support Unicode. The runtime
+system performs the necessary conversions so that the OCaml programmer only
+needs to deal with the OCaml encoding. C stubs that call Windows Unicode APIs
+need to use specific runtime functions to perform the necessary conversions in a
+compatible way.
+
+\item When writing stubs that need to be compiled under both Windows and Unix,
+the stubs need to be written in a way that allow the necessary conversions under
+Windows but that also work under Unix, where typically nothing particular needs
+to be done to support Unicode.
+
+\end{itemize}
+
+The native C character type under Windows is "WCHAR", two bytes wide, while
+under Unix it is "char", one byte wide. A type "char_os" is defined in
+"<caml/misc.h>" that stands for the concrete C character type of each
+platform. Strings in the platform encoding are of type "char_os *".
+
+The following functions are exposed to help write compatible C stubs. To use
+them, you need to include both "<caml/misc.h>" and "<caml/osdeps.h>".
+
+\begin{itemize}
+
+\item "char_os* caml_stat_strdup_to_os(const char *)" copies the argument while
+translating from OCaml encoding to the platform encoding. This function is
+typically used to convert the "char *" underlying an OCaml string before passing
+it to an operating system API that takes a Unicode argument. Under Unix, it is
+equivalent to "caml_stat_strdup".
+
+{\bf Note:} For maximum backwards compatibility in Unicode mode, if the argument
+is not a valid UTF-8 string, this function will fall back to assuming that it is
+encoded in the current code page.
+
+\item "char* caml_stat_strdup_of_os(const char_os *)" copies the argument while
+translating from the platform encoding to the OCaml encoding. It is the inverse
+of "caml_stat_strdup_to_os". This function is typically used to convert a string
+obtained from the operating system before passing it on to OCaml code. Under
+Unix, it is equivalent to "caml_stat_strdup".
+
+\item "value caml_copy_string_of_os(char_os *)" allocates an OCaml string with
+contents equal to the argument string converted to the OCaml encoding. This
+function is essentially equivalent to "caml_stat_strdup_of_os" followed by
+"caml_copy_string", except that it avoids the allocation of the intermediate
+string returned by "caml_stat_strdup_of_os". Under Unix, it is equivalent to
+"caml_copy_string".
+
+\end{itemize}
+
+{\bf Note:} The strings returned by "caml_stat_strdup_to_os" and
+"caml_stat_strdup_of_os" are allocated using "caml_stat_alloc", so they need to
+be deallocated using "caml_stat_free" when they are no longer needed.
+
+\paragraph{Example} We want to bind the function "getenv" in a way that works
+both under Unix and Windows. Under Unix this function has the prototype:
+
+\begin{verbatim}
+ char *getenv(const char *);
+\end{verbatim}
+While the Unicode version under Windows has the prototype:
+\begin{verbatim}
+ WCHAR *_wgetenv(const WCHAR *);
+\end{verbatim}
+
+In terms of "char_os", both functions take an argument of type "char_os *" and
+return a result of the same type. We begin by choosing the right implementation
+of the function to bind:
+
+\begin{verbatim}
+#ifdef _WIN32
+#define getenv_os _wgetenv
+#else
+#define getenv_os getenv
+#endif
+\end{verbatim}
+
+The rest of the binding is the same for both platforms:
+
+\begin{verbatim}
+/* The following define is necessary because the API is experimental */
+#define CAML_INTERNALS
+
+#include <caml/mlvalues.h>
+#include <caml/misc.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/osdeps.h>
+#include <stdlib.h>
+
+CAMLprim value stub_getenv(value var_name)
+{
+ CAMLparam1(var_name);
+ CAMLlocal1(var_value);
+ char_os *var_name_os, *var_value_os;
+
+ var_name_os = caml_stat_strdup_to_os(String_val(var_name));
+ var_value_os = getenv_os(var_name_os);
+ caml_stat_free(var_name_os);
+
+ if (var_value_os == NULL)
+ caml_raise_not_found();
+
+ var_value = caml_copy_string_of_os(var_value_os);
+
+ CAMLreturn(var_value);
+}
+\end{verbatim}
+
+\section{Building mixed C/OCaml libraries: \texttt{ocamlmklib}}
+\label{s-ocamlmklib}
+
+The "ocamlmklib" command facilitates the construction of libraries
+containing both OCaml code and C code, and usable both in static
+linking and dynamic linking modes. This command is available under
+Windows since Objective Caml 3.11 and under other operating systems since
+Objective Caml 3.03.
+
+The "ocamlmklib" command takes three kinds of arguments:
+\begin{itemize}
+\item OCaml source files and object files (".cmo", ".cmx", ".ml")
+comprising the OCaml part of the library;
+\item C object files (".o", ".a", respectively, ".obj", ".lib")
+ comprising the C part of the library;
+\item Support libraries for the C part ("-l"\var{lib}).
+\end{itemize}
+It generates the following outputs:
+\begin{itemize}
+\item An OCaml bytecode library ".cma" incorporating the ".cmo" and
+".ml" OCaml files given as arguments, and automatically referencing the
+C library generated with the C object files.
+\item An OCaml native-code library ".cmxa" incorporating the ".cmx" and
+".ml" OCaml files given as arguments, and automatically referencing the
+C library generated with the C object files.
+\item If dynamic linking is supported on the target platform, a
+".so" (respectively, ".dll") shared library built from the C object files given as arguments,
+and automatically referencing the support libraries.
+\item A C static library ".a"(respectively, ".lib") built from the C object files.
+\end{itemize}
+In addition, the following options are recognized:
+\begin{options}
+\item["-cclib", "-ccopt", "-I", "-linkall"]
+These options are passed as is to "ocamlc" or "ocamlopt".
+See the documentation of these commands.
+\item["-rpath", "-R", "-Wl,-rpath", "-Wl,-R"]
+These options are passed as is to the C compiler. Refer to the
+documentation of the C compiler.
+\item["-custom"] Force the construction of a statically linked library
+only, even if dynamic linking is supported.
+\item["-failsafe"] Fall back to building a statically linked library
+if a problem occurs while building the shared library (e.g. some of
+the support libraries are not available as shared libraries).
+\item["-L"\var{dir}] Add \var{dir} to the search path for support
+libraries ("-l"\var{lib}).
+\item["-ocamlc" \var{cmd}] Use \var{cmd} instead of "ocamlc" to call
+the bytecode compiler.
+\item["-ocamlopt" \var{cmd}] Use \var{cmd} instead of "ocamlopt" to call
+the native-code compiler.
+\item["-o" \var{output}] Set the name of the generated OCaml library.
+"ocamlmklib" will generate \var{output}".cma" and/or \var{output}".cmxa".
+If not specified, defaults to "a".
+\item["-oc" \var{outputc}] Set the name of the generated C library.
+"ocamlmklib" will generate "lib"\var{outputc}".so" (if shared
+libraries are supported) and "lib"\var{outputc}".a".
+If not specified, defaults to the output name given with "-o".
+\end{options}
+
+\noindent
+On native Windows, the following environment variable is also consulted:
+
+\begin{options}
+\item["OCAML_FLEXLINK"] Alternative executable to use instead of the
+configured value. Primarily used for bootstrapping.
+\end{options}
+
+\paragraph{Example} Consider an OCaml interface to the standard "libz"
+C library for reading and writing compressed files. Assume this
+library resides in "/usr/local/zlib". This interface is
+composed of an OCaml part "zip.cmo"/"zip.cmx" and a C part "zipstubs.o"
+containing the stub code around the "libz" entry points. The
+following command builds the OCaml libraries "zip.cma" and "zip.cmxa",
+as well as the companion C libraries "dllzip.so" and "libzip.a":
+\begin{verbatim}
+ocamlmklib -o zip zip.cmo zip.cmx zipstubs.o -lz -L/usr/local/zlib
+\end{verbatim}
+If shared libraries are supported, this performs the following
+commands:
+\begin{verbatim}
+ocamlc -a -o zip.cma zip.cmo -dllib -lzip \
+ -cclib -lzip -cclib -lz -ccopt -L/usr/local/zlib
+ocamlopt -a -o zip.cmxa zip.cmx -cclib -lzip \
+ -cclib -lzip -cclib -lz -ccopt -L/usr/local/zlib
+gcc -shared -o dllzip.so zipstubs.o -lz -L/usr/local/zlib
+ar rc libzip.a zipstubs.o
+\end{verbatim}
+Note: This example is on a Unix system. The exact command lines
+may be different on other systems.
+
+If shared libraries are not supported, the following commands are
+performed instead:
+\begin{verbatim}
+ocamlc -a -custom -o zip.cma zip.cmo -cclib -lzip \
+ -cclib -lz -ccopt -L/usr/local/zlib
+ocamlopt -a -o zip.cmxa zip.cmx -lzip \
+ -cclib -lz -ccopt -L/usr/local/zlib
+ar rc libzip.a zipstubs.o
+\end{verbatim}
+Instead of building simultaneously the bytecode library, the
+native-code library and the C libraries, "ocamlmklib" can be called
+three times to build each separately. Thus,
+\begin{verbatim}
+ocamlmklib -o zip zip.cmo -lz -L/usr/local/zlib
+\end{verbatim}
+builds the bytecode library "zip.cma", and
+\begin{verbatim}
+ocamlmklib -o zip zip.cmx -lz -L/usr/local/zlib
+\end{verbatim}
+builds the native-code library "zip.cmxa", and
+\begin{verbatim}
+ocamlmklib -o zip zipstubs.o -lz -L/usr/local/zlib
+\end{verbatim}
+builds the C libraries "dllzip.so" and "libzip.a". Notice that the
+support libraries ("-lz") and the corresponding options
+("-L/usr/local/zlib") must be given on all three invocations of "ocamlmklib",
+because they are needed at different times depending on whether shared
+libraries are supported.
--- /dev/null
+\chapter{Lexer and parser generators (ocamllex, ocamlyacc)}
+\label{c:ocamlyacc}
+\pdfchapter{Lexer and parser generators (ocamllex, ocamlyacc)}
+%HEVEA\cutname{lexyacc.html}
+
+This chapter describes two program generators: "ocamllex", that
+produces a lexical analyzer from a set of regular expressions with
+associated semantic actions, and "ocamlyacc", that produces a parser
+from a grammar with associated semantic actions.
+
+These program generators are very close to the well-known "lex" and
+"yacc" commands that can be found in most C programming environments.
+This chapter assumes a working knowledge of "lex" and "yacc": while
+it describes the input syntax for "ocamllex" and "ocamlyacc" and the
+main differences with "lex" and "yacc", it does not explain the basics
+of writing a lexer or parser description in "lex" and "yacc". Readers
+unfamiliar with "lex" and "yacc" are referred to ``Compilers:
+principles, techniques, and tools'' by Aho, Sethi and Ullman
+(Addison-Wesley, 1986), or ``Lex $\&$ Yacc'', by Levine, Mason and
+Brown (O'Reilly, 1992).
+
+\section{Overview of \texttt{ocamllex}}
+
+The "ocamllex" command produces a lexical analyzer from a set of regular
+expressions with attached semantic actions, in the style of
+"lex". Assuming the input file is \var{lexer}".mll", executing
+\begin{alltt}
+ ocamllex \var{lexer}.mll
+\end{alltt}
+produces OCaml code for a lexical analyzer in file \var{lexer}".ml".
+This file defines one lexing function per entry point in the lexer
+definition. These functions have the same names as the entry
+points. Lexing functions take as argument a lexer buffer, and return
+the semantic attribute of the corresponding entry point.
+
+Lexer buffers are an abstract data type implemented in the standard
+library module "Lexing". The functions "Lexing.from_channel",
+"Lexing.from_string" and "Lexing.from_function" create
+lexer buffers that read from an input channel, a character string, or
+any reading function, respectively. (See the description of module
+"Lexing" in chapter~\ref{c:stdlib}.)
+
+When used in conjunction with a parser generated by "ocamlyacc", the
+semantic actions compute a value belonging to the type "token" defined
+by the generated parsing module. (See the description of "ocamlyacc"
+below.)
+
+\subsection{Options}
+The following command-line options are recognized by "ocamllex".
+
+\begin{options}
+
+\item["-ml"]
+Output code that does not use OCaml's built-in automata
+interpreter. Instead, the automaton is encoded by OCaml functions.
+This option mainly is useful for debugging "ocamllex", using it for
+production lexers is not recommended.
+
+\item["-o" \var{output-file}]
+Specify the name of the output file produced by "ocamllex".
+The default is the input file name with its extension replaced by ".ml".
+
+\item["-q"]
+Quiet mode. "ocamllex" normally outputs informational messages
+to standard output. They are suppressed if option "-q" is used.
+
+\item["-v" or "-version"]
+Print version string and exit.
+
+\item["-vnum"]
+Print short version number and exit.
+
+\item["-help" or "--help"]
+Display a short usage summary and exit.
+%
+\end{options}
+
+\section{Syntax of lexer definitions}
+
+The format of lexer definitions is as follows:
+\begin{alltt}
+\{ \var{header} \}
+let \var{ident} = \var{regexp} \ldots
+[refill \{ \var{refill-handler} \}]
+rule \var{entrypoint} [\nth{arg}{1}\ldots{} \nth{arg}{n}] =
+ parse \var{regexp} \{ \var{action} \}
+ | \ldots
+ | \var{regexp} \{ \var{action} \}
+and \var{entrypoint} [\nth{arg}{1}\ldots{} \nth{arg}{n}] =
+ parse \ldots
+and \ldots
+\{ \var{trailer} \}
+\end{alltt}
+Comments are delimited by "(*" and "*)", as in OCaml.
+The "parse" keyword, can be replaced by the "shortest" keyword, with
+the semantic consequences explained below.
+
+Refill handlers are a recent (optional) feature introduced in 4.02,
+documented below in subsection~\ref{ss:refill-handlers}.
+
+\subsection{Header and trailer}
+The {\it header} and {\it trailer} sections are arbitrary OCaml
+text enclosed in curly braces. Either or both can be omitted. If
+present, the header text is copied as is at the beginning of the
+output file and the trailer text at the end. Typically, the
+header section contains the "open" directives required
+by the actions, and possibly some auxiliary functions used in the
+actions.
+
+\subsection{Naming regular expressions}
+
+Between the header and the entry points, one can give names to
+frequently-occurring regular expressions. This is written
+@"let" ident "=" regexp@.
+In regular expressions that follow this declaration, the identifier
+\var{ident} can be used as shorthand for \var{regexp}.
+
+\subsection{Entry points}
+
+The names of the entry points must be valid identifiers for OCaml
+values (starting with a lowercase letter).
+Similarily, the arguments \texttt{\var{arg$_1$}\ldots{}
+\var{arg$_n$}} must be valid identifiers for OCaml.
+Each entry point becomes an
+OCaml function that takes $n+1$ arguments,
+the extra implicit last argument being of type "Lexing.lexbuf".
+Characters are read from the "Lexing.lexbuf" argument and matched
+against the regular expressions provided in the rule, until a prefix
+of the input matches one of the rule. The corresponding action is
+then evaluated and returned as the result of the function.
+
+
+If several regular expressions match a prefix of the input, the
+``longest match'' rule applies: the regular expression that matches
+the longest prefix of the input is selected. In case of tie, the
+regular expression that occurs earlier in the rule is selected.
+
+However, if lexer rules are introduced with the "shortest" keyword in
+place of the "parse" keyword, then the ``shortest match'' rule applies:
+the shortest prefix of the input is selected. In case of tie, the
+regular expression that occurs earlier in the rule is still selected.
+This feature is not intended for use in ordinary lexical analyzers, it
+may facilitate the use of "ocamllex" as a simple text processing tool.
+
+
+
+\subsection{Regular expressions}
+
+The regular expressions are in the style of "lex", with a more
+OCaml-like syntax.
+\begin{syntax}
+regexp:
+ \ldots
+\end{syntax}
+\begin{options}
+
+\item[@"'" regular-char || escape-sequence "'"@]
+A character constant, with the same syntax as OCaml character
+constants. Match the denoted character.
+
+\item["_"]
+(underscore) Match any character.
+
+\item[@"eof"@]
+Match the end of the lexer input.\\
+{\bf Note:} On some systems, with interactive input, an end-of-file
+may be followed by more characters. However, "ocamllex" will not
+correctly handle regular expressions that contain "eof" followed by
+something else.
+
+\item[@'"' { string-character } '"'@]
+A string constant, with the same syntax as OCaml string
+constants. Match the corresponding sequence of characters.
+
+\item[@'[' character-set ']'@]
+Match any single character belonging to the given
+character set. Valid character sets are: single
+character constants @"'" @c@ "'"@; ranges of characters
+@"'" @c@_1 "'" "-" "'" @c@_2 "'"@ (all characters between $c_1$ and $c_2$,
+inclusive); and the union of two or more character sets, denoted by
+concatenation.
+
+\item[@'[' '^' character-set ']'@]
+Match any single character not belonging to the given character set.
+
+
+\item[@regexp_1 '#' regexp_2@]
+(difference of character sets)
+Regular expressions @regexp_1@ and @regexp_2@ must be character sets
+defined with @'['\ldots ']'@ (or a single character expression or
+underscore "_").
+Match the difference of the two specified character sets.
+
+
+\item[@regexp '*'@]
+(repetition) Match the concatenation of zero or more
+strings that match @regexp@.
+
+\item[@regexp '+'@]
+(strict repetition) Match the concatenation of one or more
+strings that match @regexp@.
+
+\item[@regexp '?'@]
+(option) Match the empty string, or a string matching @regexp@.
+
+\item[@regexp_1 '|' regexp_2@]
+(alternative) Match any string that matches @regexp_1@ or @regexp_2@
+
+\item[@regexp_1 regexp_2@]
+(concatenation) Match the concatenation of two strings, the first
+matching @regexp_1@, the second matching @regexp_2@.
+
+\item[@'(' regexp ')'@]
+Match the same strings as @regexp@.
+
+\item[@ident@]
+Reference the regular expression bound to @ident@ by an earlier
+@"let" ident "=" regexp@ definition.
+
+\item[@regexp 'as' ident@]
+Bind the substring matched by @regexp@ to identifier @ident@.
+\end{options}
+
+Concerning the precedences of operators, "#" has the highest precedence,
+followed by "*", "+" and "?",
+then concatenation, then "|" (alternation), then "as".
+
+\subsection{Actions}
+
+The actions are arbitrary OCaml expressions. They are evaluated in
+a context where the identifiers defined by using the "as" construct
+are bound to subparts of the matched string.
+Additionally, "lexbuf" is bound to the current lexer
+buffer. Some typical uses for "lexbuf", in conjunction with the
+operations on lexer buffers provided by the "Lexing" standard library
+module, are listed below.
+
+\begin{options}
+\item["Lexing.lexeme lexbuf"]
+Return the matched string.
+
+\item["Lexing.lexeme_char lexbuf "$n$]
+Return the $n\th$
+character in the matched string. The first character corresponds to $n = 0$.
+
+\item["Lexing.lexeme_start lexbuf"]
+Return the absolute position in the input text of the beginning of the
+matched string (i.e. the offset of the first character of the matched
+string). The first character read from the input text has offset 0.
+
+\item["Lexing.lexeme_end lexbuf"]
+Return the absolute position in the input text of the end of the
+matched string (i.e. the offset of the first character after the
+matched string). The first character read from the input text has
+offset 0.
+
+\newcommand{\sub}[1]{$_{#1}$}%
+\item[\var{entrypoint} {[\var{exp\sub{1}}\ldots{} \var{exp\sub{n}}]} "lexbuf"]
+(Where \var{entrypoint} is the name of another entry point in the same
+lexer definition.) Recursively call the lexer on the given entry point.
+Notice that "lexbuf" is the last argument.
+Useful for lexing nested comments, for example.
+
+\end{options}
+
+\subsection{Variables in regular expressions}
+The "as" construct is similar to ``\emph{groups}'' as provided by
+numerous regular expression packages.
+The type of these variables can be "string", "char", "string option"
+or "char option".
+
+We first consider the case of linear patterns, that is the case when
+all "as" bound variables are distinct.
+In @regexp 'as' ident@, the type of @ident@ normally is "string" (or
+"string option") except
+when @regexp@ is a character constant, an underscore, a string
+constant of length one, a character set specification, or an
+alternation of those. Then, the type of @ident@ is "char" (or "char
+option").
+Option types are introduced when overall rule matching does not
+imply matching of the bound sub-pattern. This is in particular the
+case of @'(' regexp 'as' ident ')' '?'@ and of
+@regexp_1 '|' '(' regexp_2 'as' ident ')'@.
+
+There is no linearity restriction over "as" bound variables.
+When a variable is bound more than once, the previous rules are to be
+extended as follows:
+\begin{itemize}
+\item A variable is a "char" variable when all its occurrences bind
+"char" occurrences in the previous sense.
+\item A variable is an "option" variable when the overall expression
+can be matched without binding this variable.
+\end{itemize}
+For instance, in
+"('a' as x) | ( 'a' (_ as x) )" the variable "x" is of type
+"char", whereas in
+"(\"ab\" as x) | ( 'a' (_ as x) ? )" the variable "x" is of type
+"string option".
+
+
+In some cases, a successful match may not yield a unique set of bindings.
+For instance the matching of \verb+aba+ by the regular expression
+"(('a'|\"ab\") as x) ((\"ba\"|'a') as y)" may result in binding
+either
+\verb+x+ to \verb+"ab"+ and \verb+y+ to \verb+"a"+, or
+\verb+x+ to \verb+"a"+ and \verb+y+ to \verb+"ba"+.
+The automata produced "ocamllex" on such ambiguous regular
+expressions will select one of the possible resulting sets of
+bindings.
+The selected set of bindings is purposely left unspecified.
+
+\subsection{Refill handlers}
+\label{ss:refill-handlers}
+
+By default, when ocamllex reaches the end of its lexing buffer, it
+will silently call the "refill_buff" function of "lexbuf" structure
+and continue lexing. It is sometimes useful to be able to take control
+of refilling action; typically, if you use a library for asynchronous
+computation, you may want to wrap the refilling action in a delaying
+function to avoid blocking synchronous operations.
+
+Since OCaml 4.02, it is possible to specify a \var{refill-handler},
+a function that will be called when refill happens. It is passed the
+continuation of the lexing, on which it has total control. The OCaml
+expression used as refill action should have a type that is an
+instance of
+\begin{verbatim}
+ (Lexing.lexbuf -> 'a) -> Lexing.lexbuf -> 'a
+\end{verbatim}
+where the first argument is the continuation which captures the
+processing ocamllex would usually perform (refilling the buffer, then
+calling the lexing function again), and the result type that
+instantiates ['a] should unify with the result type of all lexing
+rules.
+
+As an example, consider the following lexer that is parametrized over
+an arbitrary monad:
+\begin{verbatim}
+{
+type token = EOL | INT of int | PLUS
+
+module Make (M : sig
+ type 'a t
+ val return: 'a -> 'a t
+ val bind: 'a t -> ('a -> 'b t) -> 'b t
+ val fail : string -> 'a t
+
+ (* Set up lexbuf *)
+ val on_refill : Lexing.lexbuf -> unit t
+ end)
+= struct
+
+let refill_handler k lexbuf =
+ M.bind (M.on_refill lexbuf) (fun () -> k lexbuf)
+
+}
+
+refill {refill_handler}
+
+rule token = parse
+| [' ' '\t']
+ { token lexbuf }
+| '\n'
+ { M.return EOL }
+| ['0'-'9']+ as i
+ { M.return (INT (int_of_string i)) }
+| '+'
+ { M.return PLUS }
+| _
+ { M.fail "unexpected character" }
+{
+end
+}
+\end{verbatim}
+
+\subsection{Reserved identifiers}
+
+All identifiers starting with "__ocaml_lex" are reserved for use by
+"ocamllex"; do not use any such identifier in your programs.
+
+
+\section{Overview of \texttt{ocamlyacc}}
+
+The "ocamlyacc" command produces a parser from a context-free grammar
+specification with attached semantic actions, in the style of "yacc".
+Assuming the input file is \var{grammar}".mly", executing
+\begin{alltt}
+ ocamlyacc \var{options} \var{grammar}.mly
+\end{alltt}
+produces OCaml code for a parser in the file \var{grammar}".ml",
+and its interface in file \var{grammar}".mli".
+
+The generated module defines one parsing function per entry point in
+the grammar. These functions have the same names as the entry points.
+Parsing functions take as arguments a lexical analyzer (a function
+from lexer buffers to tokens) and a lexer buffer, and return the
+semantic attribute of the corresponding entry point. Lexical analyzer
+functions are usually generated from a lexer specification by the
+"ocamllex" program. Lexer buffers are an abstract data type
+implemented in the standard library module "Lexing". Tokens are values from
+the concrete type "token", defined in the interface file
+\var{grammar}".mli" produced by "ocamlyacc".
+
+\section{Syntax of grammar definitions}
+
+Grammar definitions have the following format:
+\begin{alltt}
+\%\{
+ \var{header}
+\%\}
+ \var{declarations}
+\%\%
+ \var{rules}
+\%\%
+ \var{trailer}
+\end{alltt}
+
+Comments are enclosed between \verb|/*| and \verb|*/| (as in C) in the
+``declarations'' and ``rules'' sections, and between \verb|(*| and
+\verb|*)| (as in OCaml) in the ``header'' and ``trailer'' sections.
+
+\subsection{Header and trailer}
+
+The header and the trailer sections are OCaml code that is copied
+as is into file \var{grammar}".ml". Both sections are optional. The header
+goes at the beginning of the output file; it usually contains
+"open" directives and auxiliary functions required by the semantic
+actions of the rules. The trailer goes at the end of the output file.
+
+\subsection{Declarations}
+
+Declarations are given one per line. They all start with a \verb"%" sign.
+
+\begin{options}
+
+\item[@"%token" constr \ldots constr@]
+Declare the given symbols @constr \ldots constr@
+as tokens (terminal symbols). These symbols
+are added as constant constructors for the "token" concrete type.
+
+\item[@"%token" "<" typexpr ">" constr \ldots constr@]
+Declare the given symbols @constr \ldots constr@ as tokens with an
+attached attribute of the
+given type. These symbols are added as constructors with arguments of
+the given type for the "token" concrete type. The @typexpr@ part is
+an arbitrary OCaml type expression, except that all type
+constructor names must be fully qualified (e.g. "Modname.typename")
+for all types except standard built-in types, even if the proper
+\verb|open| directives (e.g. \verb|open Modname|) were given in the
+header section. That's because the header is copied only to the ".ml"
+output file, but not to the ".mli" output file, while the @typexpr@ part
+of a \verb"%token" declaration is copied to both.
+
+\item[@"%start" symbol \ldots symbol@]
+Declare the given symbols as entry points for the grammar. For each
+entry point, a parsing function with the same name is defined in the
+output module. Non-terminals that are not declared as entry points
+have no such parsing function. Start symbols must be given a type with
+the \verb|%type| directive below.
+
+\item[@"%type" "<" typexpr ">" symbol \ldots symbol@]
+Specify the type of the semantic attributes for the given symbols.
+This is mandatory for start symbols only. Other nonterminal symbols
+need not be given types by hand: these types will be inferred when
+running the output files through the OCaml compiler (unless the
+\verb"-s" option is in effect). The @typexpr@ part is an arbitrary OCaml
+type expression, except that all type constructor names must be
+fully qualified, as explained above for "%token".
+
+\item[@"%left" symbol \ldots symbol@]
+\item[@"%right" symbol \ldots symbol@]
+\item[@"%nonassoc" symbol \ldots symbol@]
+
+Associate precedences and associativities to the given symbols. All
+symbols on the same line are given the same precedence. They have
+higher precedence than symbols declared before in a \verb"%left",
+\verb"%right" or \verb"%nonassoc" line. They have lower precedence
+than symbols declared after in a \verb"%left", \verb"%right" or
+\verb"%nonassoc" line. The symbols are declared to associate to the
+left (\verb"%left"), to the right (\verb"%right"), or to be
+non-associative (\verb"%nonassoc"). The symbols are usually tokens.
+They can also be dummy nonterminals, for use with the \verb"%prec"
+directive inside the rules.
+
+The precedence declarations are used in the following way to
+resolve reduce/reduce and shift/reduce conflicts:
+\begin{itemize}
+\item Tokens and rules have precedences. By default, the precedence
+ of a rule is the precedence of its rightmost terminal. You
+ can override this default by using the @"%prec"@ directive in the rule.
+\item A reduce/reduce conflict
+ is resolved in favor of the first rule (in the order given by the
+ source file), and "ocamlyacc" outputs a warning.
+\item A shift/reduce conflict
+ is resolved by comparing the precedence of the rule to be
+ reduced with the precedence of the token to be shifted. If the
+ precedence of the rule is higher, then the rule will be reduced;
+ if the precedence of the token is higher, then the token will
+ be shifted.
+\item A shift/reduce conflict between a rule and a token with the
+ same precedence will be resolved using the associativity: if the
+ token is left-associative, then the parser will reduce; if the
+ token is right-associative, then the parser will shift. If the
+ token is non-associative, then the parser will declare a syntax
+ error.
+\item When a shift/reduce conflict cannot be resolved using the above
+ method, then "ocamlyacc" will output a warning and the parser will
+ always shift.
+\end{itemize}
+
+\end{options}
+
+\subsection{Rules}
+
+The syntax for rules is as usual:
+\begin{alltt}
+\var{nonterminal} :
+ \var{symbol} \ldots \var{symbol} \{ \var{semantic-action} \}
+ | \ldots
+ | \var{symbol} \ldots \var{symbol} \{ \var{semantic-action} \}
+;
+\end{alltt}
+%
+Rules can also contain the \verb"%prec "{\it symbol} directive in the
+right-hand side part, to override the default precedence and
+associativity of the rule with the precedence and associativity of the
+given symbol.
+
+Semantic actions are arbitrary OCaml expressions, that
+are evaluated to produce the semantic attribute attached to
+the defined nonterminal. The semantic actions can access the
+semantic attributes of the symbols in the right-hand side of
+the rule with the \verb"$" notation: \verb"$1" is the attribute for the
+first (leftmost) symbol, \verb"$2" is the attribute for the second
+symbol, etc.
+
+The rules may contain the special symbol "error" to indicate
+resynchronization points, as in "yacc".
+
+Actions occurring in the middle of rules are not supported.
+
+Nonterminal symbols are like regular OCaml symbols, except that they
+cannot end with "'" (single quote).
+
+\subsection{Error handling}
+
+Error recovery is supported as follows: when the parser reaches an
+error state (no grammar rules can apply), it calls a function named
+"parse_error" with the string "\"syntax error\"" as argument. The default
+"parse_error" function does nothing and returns, thus initiating error
+recovery (see below). The user can define a customized "parse_error"
+function in the header section of the grammar file.
+
+The parser also enters error recovery mode if one of the grammar
+actions raises the "Parsing.Parse_error" exception.
+
+In error recovery mode, the parser discards states from the
+stack until it reaches a place where the error token can be shifted.
+It then discards tokens from the input until it finds three successive
+tokens that can be accepted, and starts processing with the first of
+these. If no state can be uncovered where the error token can be
+shifted, then the parser aborts by raising the "Parsing.Parse_error"
+exception.
+
+Refer to documentation on "yacc" for more details and guidance in how
+to use error recovery.
+
+\section{Options}
+
+The "ocamlyacc" command recognizes the following options:
+
+\begin{options}
+
+\item["-b"{\it prefix}]
+Name the output files {\it prefix}".ml", {\it prefix}".mli",
+{\it prefix}".output", instead of the default naming convention.
+
+\item["-q"]
+This option has no effect.
+
+\item["-v"]
+Generate a description of the parsing tables and a report on conflicts
+resulting from ambiguities in the grammar. The description is put in
+file \var{grammar}".output".
+
+\item["-version"]
+Print version string and exit.
+
+\item["-vnum"]
+Print short version number and exit.
+
+\item["-"]
+Read the grammar specification from standard input. The default
+output file names are "stdin.ml" and "stdin.mli".
+
+\item["--" \var{file}]
+Process \var{file} as the grammar specification, even if its name
+starts with a dash (-) character. This option must be the last on the
+command line.
+
+\end{options}
+
+At run-time, the "ocamlyacc"-generated parser can be debugged by
+setting the "p" option in the "OCAMLRUNPARAM" environment variable
+(see section~\ref{ocamlrun-options}). This causes the pushdown
+automaton executing the parser to print a trace of its action (tokens
+shifted, rules reduced, etc). The trace mentions rule numbers and
+state numbers that can be interpreted by looking at the file
+\var{grammar}".output" generated by "ocamlyacc -v".
+
+\section{A complete example}
+
+The all-time favorite: a desk calculator. This program reads
+arithmetic expressions on standard input, one per line, and prints
+their values. Here is the grammar definition:
+\begin{verbatim}
+ /* File parser.mly */
+ %token <int> INT
+ %token PLUS MINUS TIMES DIV
+ %token LPAREN RPAREN
+ %token EOL
+ %left PLUS MINUS /* lowest precedence */
+ %left TIMES DIV /* medium precedence */
+ %nonassoc UMINUS /* highest precedence */
+ %start main /* the entry point */
+ %type <int> main
+ %%
+ main:
+ expr EOL { $1 }
+ ;
+ expr:
+ INT { $1 }
+ | LPAREN expr RPAREN { $2 }
+ | expr PLUS expr { $1 + $3 }
+ | expr MINUS expr { $1 - $3 }
+ | expr TIMES expr { $1 * $3 }
+ | expr DIV expr { $1 / $3 }
+ | MINUS expr %prec UMINUS { - $2 }
+ ;
+\end{verbatim}
+Here is the definition for the corresponding lexer:
+\begin{verbatim}
+ (* File lexer.mll *)
+ {
+ open Parser (* The type token is defined in parser.mli *)
+ exception Eof
+ }
+ rule token = parse
+ [' ' '\t'] { token lexbuf } (* skip blanks *)
+ | ['\n' ] { EOL }
+ | ['0'-'9']+ as lxm { INT(int_of_string lxm) }
+ | '+' { PLUS }
+ | '-' { MINUS }
+ | '*' { TIMES }
+ | '/' { DIV }
+ | '(' { LPAREN }
+ | ')' { RPAREN }
+ | eof { raise Eof }
+\end{verbatim}
+Here is the main program, that combines the parser with the lexer:
+\begin{verbatim}
+ (* File calc.ml *)
+ let _ =
+ try
+ let lexbuf = Lexing.from_channel stdin in
+ while true do
+ let result = Parser.main Lexer.token lexbuf in
+ print_int result; print_newline(); flush stdout
+ done
+ with Lexer.Eof ->
+ exit 0
+\end{verbatim}
+To compile everything, execute:
+\begin{verbatim}
+ ocamllex lexer.mll # generates lexer.ml
+ ocamlyacc parser.mly # generates parser.ml and parser.mli
+ ocamlc -c parser.mli
+ ocamlc -c lexer.ml
+ ocamlc -c parser.ml
+ ocamlc -c calc.ml
+ ocamlc -o calc lexer.cmo parser.cmo calc.cmo
+\end{verbatim}
+
+\section{Common errors}
+
+\begin{options}
+
+\item[ocamllex: transition table overflow, automaton is too big]
+
+The deterministic automata generated by "ocamllex" are limited to at
+most 32767 transitions. The message above indicates that your lexer
+definition is too complex and overflows this limit. This is commonly
+caused by lexer definitions that have separate rules for each of the
+alphabetic keywords of the language, as in the following example.
+\begin{verbatim}
+rule token = parse
+ "keyword1" { KWD1 }
+| "keyword2" { KWD2 }
+| ...
+| "keyword100" { KWD100 }
+| ['A'-'Z' 'a'-'z'] ['A'-'Z' 'a'-'z' '0'-'9' '_'] * as id
+ { IDENT id}
+\end{verbatim}
+To keep the generated automata small, rewrite those definitions with
+only one general ``identifier'' rule, followed by a hashtable lookup
+to separate keywords from identifiers:
+\begin{verbatim}
+{ let keyword_table = Hashtbl.create 53
+ let _ =
+ List.iter (fun (kwd, tok) -> Hashtbl.add keyword_table kwd tok)
+ [ "keyword1", KWD1;
+ "keyword2", KWD2; ...
+ "keyword100", KWD100 ]
+}
+rule token = parse
+ ['A'-'Z' 'a'-'z'] ['A'-'Z' 'a'-'z' '0'-'9' '_'] * as id
+ { try
+ Hashtbl.find keyword_table id
+ with Not_found ->
+ IDENT id }
+\end{verbatim}
+
+\item[ocamllex: Position memory overflow, too many bindings]
+The deterministic automata generated by "ocamllex" maintain a table of
+positions inside the scanned lexer buffer. The size of this table is
+limited to at most 255 cells. This error should not show up in normal
+situations.
+
+\end{options}
--- /dev/null
+\chapter{Native-code compilation (ocamlopt)} \label{c:nativecomp}
+\pdfchapter{Native-code compilation (ocamlopt)}
+%HEVEA\cutname{native.html}
+
+This chapter describes the OCaml high-performance
+native-code compiler "ocamlopt", which compiles OCaml source files to
+native code object files and links these object files to produce
+standalone executables.
+
+The native-code compiler is only available on certain platforms.
+It produces code that runs faster than the bytecode produced by
+"ocamlc", at the cost of increased compilation time and executable code
+size. Compatibility with the bytecode compiler is extremely high: the
+same source code should run identically when compiled with "ocamlc" and
+"ocamlopt".
+
+It is not possible to mix native-code object files produced by "ocamlopt"
+with bytecode object files produced by "ocamlc": a program must be
+compiled entirely with "ocamlopt" or entirely with "ocamlc". Native-code
+object files produced by "ocamlopt" cannot be loaded in the toplevel
+system "ocaml".
+
+\section{Overview of the compiler}
+
+The "ocamlopt" command has a command-line interface very close to that
+of "ocamlc". It accepts the same types of arguments, and processes them
+sequentially, after all options have been processed:
+
+\begin{itemize}
+\item
+Arguments ending in ".mli" are taken to be source files for
+compilation unit interfaces. Interfaces specify the names exported by
+compilation units: they declare value names with their types, define
+public data types, declare abstract data types, and so on. From the
+file \var{x}".mli", the "ocamlopt" compiler produces a compiled interface
+in the file \var{x}".cmi". The interface produced is identical to that
+produced by the bytecode compiler "ocamlc".
+
+\item
+Arguments ending in ".ml" are taken to be source files for compilation
+unit implementations. Implementations provide definitions for the
+names exported by the unit, and also contain expressions to be
+evaluated for their side-effects. From the file \var{x}".ml", the "ocamlopt"
+compiler produces two files: \var{x}".o", containing native object code,
+and \var{x}".cmx", containing extra information for linking and
+optimization of the clients of the unit. The compiled implementation
+should always be referred to under the name \var{x}".cmx" (when given
+a ".o" or ".obj" file, "ocamlopt" assumes that it contains code compiled from C,
+not from OCaml).
+
+The implementation is checked against the interface file \var{x}".mli"
+(if it exists) as described in the manual for "ocamlc"
+(chapter~\ref{c:camlc}).
+
+\item
+Arguments ending in ".cmx" are taken to be compiled object code. These
+files are linked together, along with the object files obtained
+by compiling ".ml" arguments (if any), and the OCaml standard
+library, to produce a native-code executable program. The order in
+which ".cmx" and ".ml" arguments are presented on the command line is
+relevant: compilation units are initialized in that order at
+run-time, and it is a link-time error to use a component of a unit
+before having initialized it. Hence, a given \var{x}".cmx" file must come
+before all ".cmx" files that refer to the unit \var{x}.
+
+\item
+Arguments ending in ".cmxa" are taken to be libraries of object code.
+Such a library packs in two files (\var{lib}".cmxa" and \var{lib}".a"/".lib")
+a set of object files (".cmx" and ".o"/".obj" files). Libraries are build with
+"ocamlopt -a" (see the description of the "-a" option below). The object
+files contained in the library are linked as regular ".cmx" files (see
+above), in the order specified when the library was built. The only
+difference is that if an object file contained in a library is not
+referenced anywhere in the program, then it is not linked in.
+
+\item
+Arguments ending in ".c" are passed to the C compiler, which generates
+a ".o"/".obj" object file. This object file is linked with the program.
+
+\item
+Arguments ending in ".o", ".a" or ".so" (".obj", ".lib" and ".dll"
+under Windows) are assumed to be C object files and
+libraries. They are linked with the program.
+
+\end{itemize}
+
+The output of the linking phase is a regular Unix or Windows
+executable file. It does not need "ocamlrun" to run.
+
+\section{Options}
+
+The following command-line options are recognized by "ocamlopt".
+The options "-pack", "-a", "-shared", "-c" and "-output-obj" are mutually
+exclusive.
+
+% Configure boolean variables used by the macros in unified-options.etex
+\compfalse
+\nattrue
+\topfalse
+% unified-options gathers all options across the native/bytecode
+% compilers and toplevel
+\input{unified-options.tex}
+
+\paragraph{Options for the IA32 architecture}
+The IA32 code generator (Intel Pentium, AMD Athlon) supports the
+following additional option:
+
+\begin{options}
+\item["-ffast-math"] Use the IA32 instructions to compute
+trigonometric and exponential functions, instead of calling the
+corresponding library routines. The functions affected are:
+"atan", "atan2", "cos", "log", "log10", "sin", "sqrt" and "tan".
+The resulting code runs faster, but the range of supported arguments
+and the precision of the result can be reduced. In particular,
+trigonometric operations "cos", "sin", "tan" have their range reduced to
+$[-2^{64}, 2^{64}]$.
+\end{options}
+
+\paragraph{Options for the AMD64 architecture}
+The AMD64 code generator (64-bit versions of Intel Pentium and AMD
+Athlon) supports the following additional options:
+
+\begin{options}
+\item["-fPIC"] Generate position-independent machine code. This is
+the default.
+\item["-fno-PIC"] Generate position-dependent machine code.
+\end{options}
+
+\paragraph{Contextual control of command-line options}
+
+The compiler command line can be modified ``from the outside''
+with the following mechanisms. These are experimental
+and subject to change. They should be used only for experimental and
+development work, not in released packages.
+
+\begin{options}
+\item["OCAMLPARAM" \rm(environment variable)]
+A set of arguments that will be inserted before or after the arguments from
+the command line. Arguments are specified in a comma-separated list
+of "name=value" pairs. A "_" is used to specify the position of
+the command line arguments, i.e. "a=x,_,b=y" means that "a=x" should be
+executed before parsing the arguments, and "b=y" after. Finally,
+an alternative separator can be specified as the
+first character of the string, within the set ":|; ,".
+\item["ocaml_compiler_internal_params" \rm(file in the stdlib directory)]
+A mapping of file names to lists of arguments that
+will be added to the command line (and "OCAMLPARAM") arguments.
+\item["OCAML_FLEXLINK" \rm(environment variable)]
+Alternative executable to use on native
+Windows for "flexlink" instead of the
+configured value. Primarily used for bootstrapping.
+\end{options}
+
+\section{Common errors}
+
+The error messages are almost identical to those of "ocamlc".
+See section~\ref{s:comp-errors}.
+
+\section{Running executables produced by ocamlopt}
+
+Executables generated by "ocamlopt" are native, stand-alone executable
+files that can be invoked directly. They do
+not depend on the "ocamlrun" bytecode runtime system nor on
+dynamically-loaded C/OCaml stub libraries.
+
+During execution of an "ocamlopt"-generated executable,
+the following environment variables are also consulted:
+\begin{options}
+\item["OCAMLRUNPARAM"] Same usage as in "ocamlrun"
+ (see section~\ref{ocamlrun-options}), except that option "l"
+ is ignored (the operating system's stack size limit
+ is used instead).
+\item["CAMLRUNPARAM"] If "OCAMLRUNPARAM" is not found in the
+ environment, then "CAMLRUNPARAM" will be used instead. If
+ "CAMLRUNPARAM" is not found, then the default values will be used.
+\end{options}
+
+\section{Compatibility with the bytecode compiler}
+\label{s:compat-native-bytecode}
+
+This section lists the known incompatibilities between the bytecode
+compiler and the native-code compiler. Except on those points, the two
+compilers should generate code that behave identically.
+
+\begin{itemize}
+
+\item Signals are detected only when the program performs an
+allocation in the heap. That is, if a signal is delivered while in a
+piece of code that does not allocate, its handler will not be called
+until the next heap allocation.
+
+\item Stack overflow, typically caused by excessively deep recursion,
+is not always turned into a "Stack_overflow" exception like the
+bytecode compiler does. The runtime system makes a best effort to
+trap stack overflows and raise the "Stack_overflow" exception, but
+sometimes it fails and a ``segmentation fault'' or another system fault
+occurs instead.
+
+\item On ARM and PowerPC processors (32 and 64 bits), fused
+ multiply-add (FMA) instructions can be generated for a
+ floating-point multiplication followed by a floating-point addition
+ or subtraction, as in "x *. y +. z". The FMA instruction avoids
+ rounding the intermediate result "x *. y", which is generally
+ beneficial, but produces floating-point results that differ slightly
+ from those produced by the bytecode interpreter.
+
+\item On IA32 processors only (Intel and AMD x86 processors in 32-bit
+mode), some intermediate results in floating-point computations are
+kept in extended precision rather than being rounded to double
+precision like the bytecode compiler always does. Floating-point
+results can therefore differ slightly between bytecode and native code.
+
+\item The native-code compiler performs a number of optimizations that
+the bytecode compiler does not perform, especially when the Flambda
+optimizer is active. In particular, the native-code compiler
+identifies and eliminates ``dead code'', i.e.\ computations that do
+not contribute to the results of the program. For example,
+\begin{verbatim}
+ let _ = ignore M.f
+\end{verbatim}
+contains a reference to compilation unit "M" when compiled to
+bytecode. This reference forces "M" to be linked and its
+initialization code to be executed. The native-code compiler
+eliminates the reference to "M", hence the compilation unit "M" may
+not be linked and executed. A workaround is to compile "M" with the
+"-linkall" flag so that it will always be linked and executed, even if
+not referenced. See also the "Sys.opaque_identity" function from the
+"Sys" standard library module.
+
+\end{itemize}
+
--- /dev/null
+\chapter{The ocamlbuild compilation manager} \label{c:ocamlbuild}
+\pdfchapter{The ocamlbuild compilation manager}
+
+Since OCaml version 4.03, the ocamlbuild compilation manager is
+distributed separately from the OCaml compiler. The project is now
+hosted at \url{https://github.com/ocaml/ocamlbuild/}.
--- /dev/null
+\chapter{The documentation generator (ocamldoc)} \label{c:ocamldoc}
+\pdfchapter{The documentation generator (ocamldoc)}
+%HEVEA\cutname{ocamldoc.html}
+
+This chapter describes OCamldoc, a tool that generates documentation from
+special comments embedded in source files. The comments used by OCamldoc
+are of the form "(**"\ldots"*)" and follow the format described
+in section \ref{s:ocamldoc-comments}.
+
+OCamldoc can produce documentation in various formats: HTML, \LaTeX ,
+TeXinfo, Unix man pages, and "dot" dependency graphs. Moreover,
+users can add their own custom generators, as explained in
+section \ref{s:ocamldoc-custom-generators}.
+
+In this chapter, we use the word {\em element} to refer to any of the
+following parts of an OCaml source file: a type declaration, a value,
+a module, an exception, a module type, a type constructor, a record
+field, a class, a class type, a class method, a class value or a class
+inheritance clause.
+
+\section{Usage} \label{s:ocamldoc-usage}
+
+\subsection{Invocation}
+
+OCamldoc is invoked via the command "ocamldoc", as follows:
+\begin{alltt}
+ ocamldoc \var{options} \var{sourcefiles}
+\end{alltt}
+
+\subsubsection*{Options for choosing the output format}
+
+The following options determine the format for the generated
+documentation.
+
+\begin{options}
+\item["-html"]
+Generate documentation in HTML default format. The generated HTML pages
+are stored in the current directory, or in the directory specified
+with the {\bf\tt -d} option. You can customize the style of the
+generated pages by editing the generated "style.css" file, or by providing
+your own style sheet using option "-css-style".
+The file "style.css" is not generated if it already exists or if -css-style is used.
+
+\item["-latex"]
+Generate documentation in \LaTeX\ default format. The generated
+\LaTeX\ document is saved in file "ocamldoc.out", or in the file
+specified with the {\bf\tt -o} option. The document uses the style file
+"ocamldoc.sty". This file is generated when using the "-latex" option,
+if it does not already exist.
+You can change this file to customize the style of your \LaTeX\ documentation.
+
+\item["-texi"]
+Generate documentation in TeXinfo default format. The generated
+\LaTeX\ document is saved in file "ocamldoc.out", or in the file
+specified with the {\bf\tt -o} option.
+
+\item["-man"]
+Generate documentation as a set of Unix "man" pages. The generated pages
+are stored in the current directory, or in the directory specified
+with the {\bf\tt -d} option.
+
+\item["-dot"]
+Generate a dependency graph for the toplevel modules, in a format suitable
+for displaying and processing by "dot". The "dot" tool is available from
+\url{http://www.research.att.com/sw/tools/graphviz/}.
+The textual representation of the graph is written to the file
+"ocamldoc.out", or to the file specified with the {\bf\tt -o} option.
+Use "dot ocamldoc.out" to display it.
+
+\item["-g" \var{file.cm[o,a,xs]}]
+Dynamically load the given file, which defines a custom documentation
+generator. See section \ref{s:ocamldoc-compilation-and-usage}. This
+option is supported by the "ocamldoc" command (to load ".cmo" and ".cma" files)
+and by its native-code version "ocamldoc.opt" (to load ".cmxs" files).
+If the given file is a simple one and does not exist in
+the current directory, then ocamldoc looks for it in the custom
+generators default directory, and in the directories specified with
+optional "-i" options.
+
+\item["-customdir"]
+Display the custom generators default directory.
+
+\item["-i" \var{directory}]
+Add the given directory to the path where to look for custom generators.
+
+\end{options}
+
+\subsubsection*{General options}
+
+\begin{options}
+
+\item["-d" \var{dir}]
+Generate files in directory \var{dir}, rather than the current directory.
+
+\item["-dump" \var{file}]
+Dump collected information into \var{file}. This information can be
+read with the "-load" option in a subsequent invocation of "ocamldoc".
+
+\item["-hide" \var{modules}]
+Hide the given complete module names in the generated documentation.
+\var{modules} is a list of complete module names separated
+ by '","', without blanks. For instance: "Pervasives,M2.M3".
+
+\item["-inv-merge-ml-mli"]
+Reverse the precedence of implementations and interfaces when merging.
+All elements
+in implementation files are kept, and the {\bf\tt -m} option
+indicates which parts of the comments in interface files are merged
+with the comments in implementation files.
+
+\item["-keep-code"]
+Always keep the source code for values, methods and instance variables,
+when available.
+
+\item["-load" \var{file}]
+Load information from \var{file}, which has been produced by
+"ocamldoc -dump". Several "-load" options can be given.
+
+\item["-m" \var{flags}]
+Specify merge options between interfaces and implementations.
+(see section \ref{s:ocamldoc-merge} for details).
+\var{flags} can be one or several of the following characters:
+\begin{options}
+ \item["d"] merge description
+ \item["a"] merge "\@author"
+ \item["v"] merge "\@version"
+ \item["l"] merge "\@see"
+ \item["s"] merge "\@since"
+ \item["b"] merge "\@before"
+ \item["o"] merge "\@deprecated"
+ \item["p"] merge "\@param"
+ \item["e"] merge "\@raise"
+ \item["r"] merge "\@return"
+ \item["A"] merge everything
+\end{options}
+
+\item["-no-custom-tags"]
+Do not allow custom \@-tags (see section \ref{s:ocamldoc-tags}).
+
+\item["-no-stop"]
+Keep elements placed after/between the "(**/**)" special comment(s)
+(see section \ref{s:ocamldoc-comments}).
+
+\item["-o" \var{file}]
+Output the generated documentation to \var{file} instead of "ocamldoc.out".
+This option is meaningful only in conjunction with the
+{\bf\tt -latex}, {\bf\tt -texi}, or {\bf\tt -dot} options.
+
+\item["-pp" \var{command}]
+Pipe sources through preprocessor \var{command}.
+
+\item["-impl" \var{filename}]
+Process the file \var{filename} as an implementation file, even if its
+extension is not ".ml".
+
+\item["-intf" \var{filename}]
+Process the file \var{filename} as an interface file, even if its
+extension is not ".mli".
+
+\item["-text" \var{filename}]
+Process the file \var{filename} as a text file, even if its
+extension is not ".txt".
+
+\item["-sort"]
+Sort the list of top-level modules before generating the documentation.
+
+\item["-stars"]
+Remove blank characters until the first asterisk ('"*"') in each
+line of comments.
+
+\item["-t" \var{title}]
+Use \var{title} as the title for the generated documentation.
+
+\item["-intro" \var{file}]
+Use content of \var{file} as ocamldoc text to use as introduction (HTML,
+\LaTeX{} and TeXinfo only).
+For HTML, the file is used to create the whole "index.html" file.
+
+\item["-v"]
+Verbose mode. Display progress information.
+
+\item["-version"]
+Print version string and exit.
+
+\item["-vnum"]
+Print short version number and exit.
+
+\item["-warn-error"]
+Treat Ocamldoc warnings as errors.
+
+\item["-hide-warnings"]
+Do not print OCamldoc warnings.
+
+\item["-help" or "--help"]
+Display a short usage summary and exit.
+%
+\end{options}
+
+\subsubsection*{Type-checking options}
+
+OCamldoc calls the OCaml type-checker to obtain type
+information. The following options impact the type-checking phase.
+They have the same meaning as for the "ocamlc" and "ocamlopt" commands.
+
+\begin{options}
+
+\item["-I" \var{directory}]
+Add \var{directory} to the list of directories search for compiled
+interface files (".cmi" files).
+
+\item["-nolabels"]
+Ignore non-optional labels in types.
+
+\item["-rectypes"]
+Allow arbitrary recursive types. (See the "-rectypes" option to "ocamlc".)
+
+\end{options}
+
+\subsubsection*{Options for generating HTML pages}
+
+The following options apply in conjunction with the "-html" option:
+
+\begin{options}
+\item["-all-params"]
+Display the complete list of parameters for functions and methods.
+
+\item["-charset" \var{charset}]
+Add information about character encoding being \var{charset}
+(default is iso-8859-1).
+
+\item["-colorize-code"]
+Colorize the OCaml code enclosed in "[ ]" and "{[ ]}", using colors
+to emphasize keywords, etc. If the code fragments are not
+syntactically correct, no color is added.
+
+\item["-css-style" \var{filename}]
+Use \var{filename} as the Cascading Style Sheet file.
+
+\item["-index-only"]
+Generate only index files.
+
+\item["-short-functors"]
+Use a short form to display functors:
+\begin{alltt}
+module M : functor (A:Module) -> functor (B:Module2) -> sig .. end
+\end{alltt}
+is displayed as:
+\begin{alltt}
+module M (A:Module) (B:Module2) : sig .. end
+\end{alltt}
+
+\end{options}
+
+\subsubsection*{Options for generating \LaTeX\ files}
+
+The following options apply in conjunction with the "-latex" option:
+
+\begin{options}
+\item["-latex-value-prefix" \var{prefix}]
+Give a prefix to use for the labels of the values in the generated
+\LaTeX\ document.
+The default prefix is the empty string. You can also use the options
+{\tt -latex-type-prefix}, {\tt -latex-exception-prefix},
+{\tt -latex-module-prefix},
+{\tt -latex-module-type-prefix}, {\tt -latex-class-prefix},
+{\tt -latex-class-type-prefix},
+{\tt -latex-attribute-prefix} and {\tt -latex-method-prefix}.
+
+These options are useful when you have, for example, a type and a value with
+ the same name. If you do not specify prefixes, \LaTeX\ will complain about
+multiply defined labels.
+
+\item["-latextitle" \var{n,style}]
+Associate style number \var{n} to the given \LaTeX\ sectioning command
+\var{style}, e.g. "section" or "subsection". (\LaTeX\ only.) This is
+useful when including the generated document in another \LaTeX\ document,
+at a given sectioning level. The default association is 1 for "section",
+2 for "subsection", 3 for "subsubsection", 4 for "paragraph" and 5 for
+"subparagraph".
+
+\item["-noheader"]
+Suppress header in generated documentation.
+
+\item["-notoc"]
+Do not generate a table of contents.
+
+\item["-notrailer"]
+Suppress trailer in generated documentation.
+
+\item["-sepfiles"]
+Generate one ".tex" file per toplevel module, instead of the global
+"ocamldoc.out" file.
+\end{options}
+
+\subsubsection*{Options for generating TeXinfo files}
+
+The following options apply in conjunction with the "-texi" option:
+
+\begin{options}
+\item["-esc8"]
+Escape accented characters in Info files.
+
+\item["-info-entry"]
+Specify Info directory entry.
+
+\item["-info-section"]
+Specify section of Info directory.
+
+\item["-noheader"]
+Suppress header in generated documentation.
+
+\item["-noindex"]
+Do not build index for Info files.
+
+\item["-notrailer"]
+Suppress trailer in generated documentation.
+\end{options}
+
+\subsubsection*{Options for generating "dot" graphs}
+
+The following options apply in conjunction with the "-dot" option:
+
+\begin{options}
+\item["-dot-colors" \var{colors}]
+Specify the colors to use in the generated "dot" code.
+When generating module dependencies, "ocamldoc" uses different colors
+for modules, depending on the directories in which they reside.
+When generating types dependencies, "ocamldoc" uses different colors
+for types, depending on the modules in which they are defined.
+\var{colors} is a list of color names separated by '","', as
+in "Red,Blue,Green". The available colors are the ones supported by
+the "dot" tool.
+
+\item["-dot-include-all"]
+Include all modules in the "dot" output, not only modules given
+on the command line or loaded with the {\bf\tt -load} option.
+
+\item["-dot-reduce"]
+Perform a transitive reduction of the dependency graph before
+outputting the "dot" code. This can be useful if there are
+a lot of transitive dependencies that clutter the graph.
+
+\item["-dot-types"]
+Output "dot" code describing the type dependency graph instead of
+the module dependency graph.
+\end{options}
+
+\subsubsection*{Options for generating man files}
+
+The following options apply in conjunction with the "-man" option:
+
+\begin{options}
+\item["-man-mini"]
+Generate man pages only for modules, module types, classes and class
+types, instead of pages for all elements.
+
+\item["-man-suffix" \var{suffix}]
+Set the suffix used for generated man filenames. Default is '"3o"',
+as in "List.3o".
+
+\item["-man-section" \var{section}]
+Set the section number used for generated man filenames. Default is '"3"'.
+
+\end{options}
+
+\subsection{Merging of module information}
+\label{s:ocamldoc-merge}
+
+Information on a module can be extracted either from the ".mli" or ".ml"
+file, or both, depending on the files given on the command line.
+When both ".mli" and ".ml" files are given for the same module,
+information extracted from these files is merged according to the
+following rules:
+\begin{itemize}
+\item Only elements (values, types, classes, ...) declared in the ".mli"
+file are kept. In other terms, definitions from the ".ml" file that are
+not exported in the ".mli" file are not documented.
+\item Descriptions of elements and descriptions in \@-tags are handled
+as follows. If a description for the same element or in the same
+\@-tag of the same element is present in both files, then the
+description of the ".ml" file is concatenated to the one in the ".mli" file,
+if the corresponding "-m" flag is given on the command line.
+If a description is present in the ".ml" file and not in the
+".mli" file, the ".ml" description is kept.
+In either case, all the information given in the ".mli" file is kept.
+\end{itemize}
+
+\subsection{Coding rules}
+\label{s:ocamldoc-rules}
+The following rules must be respected in order to avoid name clashes
+resulting in cross-reference errors:
+\begin{itemize}
+\item In a module, there must not be two modules, two module types or
+ a module and a module type with the same name.
+ In the default HTML generator, modules "ab" and "AB" will be printed
+ to the same file on case insensitive file systems.
+\item In a module, there must not be two classes, two class types or
+ a class and a class type with the same name.
+\item In a module, there must not be two values, two types, or two
+ exceptions with the same name.
+\item Values defined in tuple, as in "let (x,y,z) = (1,2,3)"
+are not kept by OCamldoc.
+\item Avoid the following construction:
+\begin{caml_eval}
+module Foo = struct module Bar = struct let x = 1 end end;;
+\end{caml_eval}
+\begin{caml_example*}{verbatim}
+open Foo (* which has a module Bar with a value x *)
+module Foo =
+ struct
+ module Bar =
+ struct
+ let x = 1
+ end
+ end
+ let dummy = Bar.x
+\end{caml_example*}
+In this case, OCamldoc will associate "Bar.x" to the "x" of module
+"Foo" defined just above, instead of to the "Bar.x" defined in the
+opened module "Foo".
+\end{itemize}
+
+\section{Syntax of documentation comments}
+\label{s:ocamldoc-comments}
+
+Comments containing documentation material are called {\em special
+comments} and are written between "(**" and "*)". Special comments
+must start exactly with "(**". Comments beginning with "(" and more
+than two "*" are ignored.
+
+\subsection{Placement of documentation comments}
+OCamldoc can associate comments to some elements of the language
+encountered in the source files. The association is made according to
+the locations of comments with respect to the language elements. The
+locations of comments in ".mli" and ".ml" files are different.
+
+%%%%%%%%%%%%%
+\subsubsection{Comments in ".mli" files}
+A special comment is associated to an element if it is placed before or
+after the element.\\
+A special comment before an element is associated to this element if~:
+\begin{itemize}
+\item There is no blank line or another special comment between the special
+comment and the element. However, a regular comment can occur between
+the special comment and the element.
+\item The special comment is not already associated to the previous element.
+\item The special comment is not the first one of a toplevel module.
+\end{itemize}
+
+A special comment after an element is associated to this element if
+there is no blank line or comment between the special comment and the
+element.
+
+There are two exceptions: for constructors and record fields in
+type definitions, the associated comment can only be placed after the
+constructor or field definition, without blank lines or other comments
+between them. The special comment for a constructor
+with another constructor following must be placed before the '"|"'
+character separating the two constructors.
+
+The following sample interface file "foo.mli" illustrates the
+placement rules for comments in ".mli" files.
+
+\begin{caml_eval}
+class cl = object end
+\end{caml_eval}
+\begin{caml_example*}{signature}
+(** The first special comment of the file is the comment associated
+ with the whole module.*)
+
+
+(** Special comments can be placed between elements and are kept
+ by the OCamldoc tool, but are not associated to any element.
+ @-tags in these comments are ignored.*)
+
+(*******************************************************************)
+(** Comments like the one above, with more than two asterisks,
+ are ignored. *)
+
+(** The comment for function f. *)
+val f : int -> int -> int
+(** The continuation of the comment for function f. *)
+
+(** Comment for exception My_exception, even with a simple comment
+ between the special comment and the exception.*)
+(* Hello, I'm a simple comment :-) *)
+exception My_exception of (int -> int) * int
+
+(** Comment for type weather *)
+type weather =
+| Rain of int (** The comment for constructor Rain *)
+| Sun (** The comment for constructor Sun *)
+
+(** Comment for type weather2 *)
+type weather2 =
+| Rain of int (** The comment for constructor Rain *)
+| Sun (** The comment for constructor Sun *)
+(** I can continue the comment for type weather2 here
+ because there is already a comment associated to the last constructor.*)
+
+(** The comment for type my_record *)
+type my_record = {
+ foo : int ; (** Comment for field foo *)
+ bar : string ; (** Comment for field bar *)
+ }
+ (** Continuation of comment for type my_record *)
+
+(** Comment for foo *)
+val foo : string
+(** This comment is associated to foo and not to bar. *)
+val bar : string
+(** This comment is associated to bar. *)
+
+(** The comment for class my_class *)
+class my_class :
+ object
+ (** A comment to describe inheritance from cl *)
+ inherit cl
+
+ (** The comment for attribute tutu *)
+ val mutable tutu : string
+
+ (** The comment for attribute toto. *)
+ val toto : int
+
+ (** This comment is not attached to titi since
+ there is a blank line before titi, but is kept
+ as a comment in the class. *)
+
+ val titi : string
+
+ (** Comment for method toto *)
+ method toto : string
+
+ (** Comment for method m *)
+ method m : float -> int
+ end
+
+(** The comment for the class type my_class_type *)
+class type my_class_type =
+ object
+ (** The comment for variable x. *)
+ val mutable x : int
+
+ (** The commend for method m. *)
+ method m : int -> int
+end
+
+(** The comment for module Foo *)
+module Foo :
+ sig
+ (** The comment for x *)
+ val x : int
+
+ (** A special comment that is kept but not associated to any element *)
+ end
+
+(** The comment for module type my_module_type. *)
+module type my_module_type =
+ sig
+ (** The comment for value x. *)
+ val x : int
+
+ (** The comment for module M. *)
+ module M :
+ sig
+ (** The comment for value y. *)
+ val y : int
+
+ (* ... *)
+ end
+
+ end
+
+\end{caml_example*}
+
+%%%%%%%%%%%%%
+\subsubsection{Comments in {\tt .ml} files}
+
+A special comment is associated to an element if it is placed before
+the element and there is no blank line between the comment and the
+element. Meanwhile, there can be a simple comment between the special
+comment and the element. There are two exceptions, for
+constructors and record fields in type definitions, whose associated
+comment must be placed after the constructor or field definition,
+without blank line between them. The special comment for a constructor
+with another constructor following must be placed before the '"|"'
+character separating the two constructors.
+
+The following example of file "toto.ml" shows where to place comments
+in a ".ml" file.
+
+\begin{caml_example*}{verbatim}
+(** The first special comment of the file is the comment associated
+ to the whole module. *)
+
+(** The comment for function f *)
+let f x y = x + y
+
+(** This comment is not attached to any element since there is another
+ special comment just before the next element. *)
+
+(** Comment for exception My_exception, even with a simple comment
+ between the special comment and the exception.*)
+(* A simple comment. *)
+exception My_exception of (int -> int) * int
+
+(** Comment for type weather *)
+type weather =
+| Rain of int (** The comment for constructor Rain *)
+| Sun (** The comment for constructor Sun *)
+
+(** The comment for type my_record *)
+type my_record = {
+ foo : int ; (** Comment for field foo *)
+ bar : string ; (** Comment for field bar *)
+ }
+
+(** The comment for class my_class *)
+class my_class =
+ object
+ (** A comment to describe inheritance from cl *)
+ inherit cl
+
+ (** The comment for the instance variable tutu *)
+ val mutable tutu = "tutu"
+ (** The comment for toto *)
+ val toto = 1
+ val titi = "titi"
+ (** Comment for method toto *)
+ method toto = tutu ^ "!"
+ (** Comment for method m *)
+ method m (f : float) = 1
+ end
+
+(** The comment for class type my_class_type *)
+class type my_class_type =
+ object
+ (** The comment for the instance variable x. *)
+ val mutable x : int
+ (** The commend for method m. *)
+ method m : int -> int
+ end
+
+(** The comment for module Foo *)
+module Foo =
+ struct
+ (** The comment for x *)
+ let x = 0
+ (** A special comment in the class, but not associated to any element. *)
+ end
+
+(** The comment for module type my_module_type. *)
+module type my_module_type =
+ sig
+ (* Comment for value x. *)
+ val x : int
+ (* ... *)
+ end
+\end{caml_example}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%
+\subsection{The Stop special comment}
+The special comment "(**/**)" tells OCamldoc to discard
+elements placed after this comment, up to the end of the current
+class, class type, module or module type, or up to the next stop comment.
+For instance:
+\begin{caml_example*}{signature}
+class type foo =
+ object
+ (** comment for method m *)
+ method m : string
+
+ (**/**)
+
+ (** This method won't appear in the documentation *)
+ method bar : int
+ end
+
+(** This value appears in the documentation, since the Stop special comment
+ in the class does not affect the parent module of the class.*)
+val foo : string
+
+(**/**)
+(** The value bar does not appear in the documentation.*)
+val bar : string
+(**/**)
+
+(** The type t appears since in the documentation since the previous stop comment
+toggled off the "no documentation mode". *)
+type t = string
+\end{caml_example*}
+
+The {\bf\tt -no-stop} option to "ocamldoc" causes the Stop special
+comments to be ignored.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%
+\subsection{Syntax of documentation comments}
+
+The inside of documentation comments "(**"\ldots"*)" consists of
+free-form text with optional formatting annotations, followed by
+optional {\em tags} giving more specific information about parameters,
+version, authors, \ldots\ The tags are distinguished by a leading "\@"
+character. Thus, a documentation comment has the following shape:
+\begin{verbatim}
+(** The comment begins with a description, which is text formatted
+ according to the rules described in the next section.
+ The description continues until the first non-escaped '@' character.
+ @author Mr Smith
+ @param x description for parameter x
+*)
+\end{verbatim}
+Some elements support only a subset of all \@-tags. Tags that are not
+relevant to the documented element are simply ignored. For instance,
+all tags are ignored when documenting type constructors, record
+fields, and class inheritance clauses. Similarly, a "\@param" tag on a
+class instance variable is ignored.
+
+At last, "(**)" is the empty documentation comment.
+
+%%%%%%%%%%%%%
+
+% enable section numbering for subsubsections (PR#6189, item 3)
+\setcounter{secnumdepth}{3}
+
+\subsection{Text formatting}
+
+Here is the BNF grammar for the simple markup language used to format
+text descriptions.
+
+\newpage
+
+\begin{syntax}
+text: {{text-element}}
+;
+\end{syntax}
+
+\noindent
+\begin{syntaxleft}
+\nonterm{text-element}\is{}
+\end{syntaxleft}
+
+\begin{tabular}{rlp{10cm}}
+@||@&@ '{' {{ "0" \ldots "9" }} text '}' @ & format @text@ as a section header;
+ the integer following "{" indicates the sectioning level. \\
+@||@&@ '{' {{ "0" \ldots "9" }} ':' @ \nt{label} @ text '}' @ &
+ same, but also associate the name \nt{label} to the current point.
+ This point can be referenced by its fully-qualified label in a
+ "{!" command, just like any other element. \\
+@||@&@ '{b' text '}' @ & set @text@ in bold. \\
+@||@&@ '{i' text '}' @ & set @text@ in italic. \\
+@||@&@ '{e' text '}' @ & emphasize @text@. \\
+@||@&@ '{C' text '}' @ & center @text@. \\
+@||@&@ '{L' text '}' @ & left align @text@. \\
+@||@&@ '{R' text '}' @ & right align @text@. \\
+@||@&@ '{ul' list '}' @ & build a list. \\
+@||@&@ '{ol' list '}' @ & build an enumerated list. \\
+@||@&@ '{{:' string '}' text '}' @ & put a link to the given address
+(given as @string@) on the given @text@. \\
+@||@&@ '[' string ']' @ & set the given @string@ in source code style. \\
+@||@&@ '{[' string ']}' @ & set the given @string@ in preformatted
+ source code style.\\
+@||@&@ '{v' string 'v}' @ & set the given @string@ in verbatim style. \\
+@||@&@ '{%' string '%}' @ & target-specific content
+ (\LaTeX\ code by default, see details
+ in \ref{sss:target-specific-syntax}) \\
+@||@&@ '{!' string '}' @ & insert a cross-reference to an element
+ (see section \ref{sss:crossref} for the syntax of cross-references).\\
+@||@&@ '{!modules:' string string ... '}' @ & insert an index table
+for the given module names. Used in HTML only.\\
+@||@&@ '{!indexlist}' @ & insert a table of links to the various indexes
+(types, values, modules, ...). Used in HTML only.\\
+@||@&@ '{^' text '}' @ & set text in superscript.\\
+@||@&@ '{_' text '}' @ & set text in subscript.\\
+@||@& \nt{escaped-string} & typeset the given string as is;
+special characters ('"{"', '"}"', '"["', '"]"' and '"\@"')
+must be escaped by a '"\\"'\\
+@||@& \nt{blank-line} & force a new line.
+\end{tabular} \\
+
+\subsubsection{List formatting}
+
+\begin{syntax}
+list:
+| {{ '{-' text '}' }}
+| {{ '{li' text '}' }}
+\end{syntax}
+
+A shortcut syntax exists for lists and enumerated lists:
+\begin{verbatim}
+(** Here is a {b list}
+- item 1
+- item 2
+- item 3
+
+The list is ended by the blank line.*)
+\end{verbatim}
+is equivalent to:
+\begin{verbatim}
+(** Here is a {b list}
+{ul {- item 1}
+{- item 2}
+{- item 3}}
+The list is ended by the blank line.*)
+\end{verbatim}
+
+The same shortcut is available for enumerated lists, using '"+"'
+instead of '"-"'.
+Note that only one list can be defined by this shortcut in nested lists.
+
+\subsubsection{Cross-reference formatting}
+\label{sss:crossref}
+
+Cross-references are fully qualified element names, as in the example
+"{!Foo.Bar.t}". This is an ambiguous reference as it may designate
+a type name, a value name, a class name, etc. It is possible to make
+explicit the intended syntactic class, using "{!type:Foo.Bar.t}" to
+designate a type, and "{!val:Foo.Bar.t}" a value of the same name.
+
+The list of possible syntactic class is as follows:
+\begin{center}
+\begin{tabular}{rl}
+\multicolumn{1}{c}{"tag"} & \multicolumn{1}{c}{syntactic class}\\ \hline
+"module:" & module \\
+"modtype:" & module type \\
+"class:" & class \\
+"classtype:" & class type \\
+"val:" & value \\
+"type:" & type \\
+"exception:" & exception \\
+"attribute:" & attribute \\
+"method:" & class method \\
+"section:" & ocamldoc section \\
+"const:" & variant constructor \\
+"recfield:" & record field
+\end{tabular}
+\end{center}
+
+In the case of variant constructors or record field, the constructor
+or field name should be preceded by the name of the correspond type --
+to avoid the ambiguity of several types having the same constructor
+names. For example, the constructor "Node" of the type "tree" will be
+referenced as "{!tree.Node}" or "{!const:tree.Node}", or possibly
+"{!Mod1.Mod2.tree.Node}" from outside the module.
+
+\subsubsection{First sentence}
+
+In the description of a value, type, exception, module, module type, class
+or class type, the {\em first sentence} is sometimes used in indexes, or
+when just a part of the description is needed. The first sentence
+is composed of the first characters of the description, until
+\begin{itemize}
+\item the first dot followed by a blank, or
+\item the first blank line
+\end{itemize}
+outside of the following text formatting :
+@ '{ul' list '}' @,
+@ '{ol' list '}' @,
+@ '[' string ']' @,
+@ '{[' string ']}' @,
+@ '{v' string 'v}' @,
+@ '{%' string '%}' @,
+@ '{!' string '}' @,
+@ '{^' text '}' @,
+@ '{_' text '}' @.
+
+\subsubsection{Target-specific formatting}
+\label{sss:target-specific-syntax}
+
+The content inside "{%foo: ... %}" is target-specific and will only be
+interpreted by the backend "foo", and ignored by the others. The
+backends of the distribution are "latex", "html", "texi" and "man". If
+no target is specified (syntax "{% ... %}"), "latex" is chosen by
+default. Custom generators may support their own target prefix.
+
+\subsubsection{Recognized HTML tags}
+The HTML tags "<b>..</b>",
+"<code>..</code>",
+"<i>..</i>",
+"<ul>..</ul>",
+"<ol>..</ol>",
+"<li>..</li>",
+"<center>..</center>" and
+"<h[0-9]>..</h[0-9]>" can be used instead of, respectively,
+@ '{b ..}' @,
+@ '[..]' @,
+@ '{i ..}' @,
+@ '{ul ..}' @,
+@ '{ol ..}' @,
+@ '{li ..}' @,
+@ '{C ..}' @ and
+"{[0-9] ..}".
+
+%disable section numbering for subsubsections
+\setcounter{secnumdepth}{2}
+
+%%%%%%%%%%%%%
+\subsection{Documentation tags (\@-tags)}
+\label{s:ocamldoc-tags}
+
+\subsubsection{Predefined tags}
+The following table gives the list of predefined \@-tags, with their
+syntax and meaning.\\
+
+\begin{tabular}{|p{5cm}|p{10cm}|}\hline
+@ "@author" string @ & The author of the element. One author per
+"\@author" tag.
+There may be several "\@author" tags for the same element. \\ \hline
+
+@ "@deprecated" text @ & The @text@ should describe when the element was
+deprecated, what to use as a replacement, and possibly the reason
+for deprecation. \\ \hline
+
+@ "@param" id text @ & Associate the given description (@text@) to the
+given parameter name @id@. This tag is used for functions,
+methods, classes and functors. \\ \hline
+
+@ "@raise" Exc text @ & Explain that the element may raise
+ the exception @Exc@. \\ \hline
+
+@ "@return" text @ & Describe the return value and
+ its possible values. This tag is used for functions
+ and methods. \\ \hline
+
+@ "@see" '<' URL '>' text @ & Add a reference to the @URL@
+with the given @text@ as comment. \\ \hline
+
+@ "@see" "'"@\nt{filename}@"'" text @ & Add a reference to the given file name
+(written between single quotes), with the given @text@ as comment. \\ \hline
+
+@ "@see" '"'@\nt{document-name}@'"' text @ & Add a reference to the given
+document name (written between double quotes), with the given @text@
+as comment. \\ \hline
+
+@ "@since" string @ & Indicate when the element was introduced. \\ \hline
+
+@ "@before" @ \nt{version} @ text @ & Associate the given description (@text@)
+to the given \nt{version} in order to document compatibility issues. \\ \hline
+
+@ "@version" string @ & The version number for the element. \\ \hline
+\end{tabular}
+
+\subsubsection{Custom tags}
+\label{s:ocamldoc-custom-tags}
+You can use custom tags in the documentation comments, but they will
+have no effect if the generator used does not handle them. To use a
+custom tag, for example "foo", just put "\@foo" with some text in your
+comment, as in:
+\begin{verbatim}
+(** My comment to show you a custom tag.
+@foo this is the text argument to the [foo] custom tag.
+*)
+\end{verbatim}
+
+To handle custom tags, you need to define a custom generator,
+as explained in section \ref{s:ocamldoc-handling-custom-tags}.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\section{Custom generators}
+\label{s:ocamldoc-custom-generators}
+
+OCamldoc operates in two steps:
+\begin{enumerate}
+\item analysis of the source files;
+\item generation of documentation, through a documentation generator,
+ which is an object of class "Odoc_args.class_generator".
+\end{enumerate}
+Users can provide their own documentation generator to be used during
+step 2 instead of the default generators.
+All the information retrieved during the analysis step is available through
+the "Odoc_info" module, which gives access to all the types and functions
+ representing the elements found in the given modules, with their associated
+description.
+
+The files you can use to define custom generators are installed in the
+"ocamldoc" sub-directory of the OCaml standard library.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%
+\subsection{The generator modules}
+The type of a generator module depends on the kind of generated documentation.
+Here is the list of generator module types, with the name of the generator
+class in the module~:
+\begin{itemize}
+\item for HTML~: "Odoc_html.Html_generator" (class "html"),
+\item for \LaTeX~: "Odoc_latex.Latex_generator" (class "latex"),
+\item for TeXinfo~: "Odoc_texi.Texi_generator" (class "texi"),
+\item for man pages~: "Odoc_man.Man_generator" (class "man"),
+\item for graphviz (dot)~: "Odoc_dot.Dot_generator" (class "dot"),
+\item for other kinds~: "Odoc_gen.Base" (class "generator").
+\end{itemize}
+That is, to define a new generator, one must implement a module with
+the expected signature, and with the given generator class, providing
+the "generate" method as entry point to make the generator generates
+documentation for a given list of modules~:
+
+\begin{verbatim}
+ method generate : Odoc_info.Module.t_module list -> unit
+\end{verbatim}
+
+\noindent{}This method will be called with the list of analysed and possibly
+merged "Odoc_info.t_module" structures.
+
+It is recommended to inherit from the current generator of the same
+kind as the one you want to define. Doing so, it is possible to
+load various custom generators to combine improvements brought by each one.
+
+This is done using first class modules (see chapter \ref{s-first-class-modules}).
+
+The easiest way to define a custom generator is the following this example,
+here extending the current HTML generator. We don't have to know if this is
+the original HTML generator defined in ocamldoc or if it has been extended
+already by a previously loaded custom generator~:
+
+\begin{verbatim}
+module Generator (G : Odoc_html.Html_generator) =
+struct
+ class html =
+ object(self)
+ inherit G.html as html
+ (* ... *)
+
+ method generate module_list =
+ (* ... *)
+ ()
+
+ (* ... *)
+ end
+end;;
+
+let _ = Odoc_args.extend_html_generator (module Generator : Odoc_gen.Html_functor);;
+\end{verbatim}
+
+To know which methods to override and/or which methods are available,
+have a look at the different base implementations, depending on the
+kind of generator you are extending~:
+\newcommand\ocamldocsrc[2]{\href{https://github.com/ocaml/ocaml/blob/{\ocamlversion}/ocamldoc/odoc_#1.ml}{#2}}
+\begin{itemize}
+\item for HTML~: \ocamldocsrc{html}{"odoc_html.ml"},
+\item for \LaTeX~: \ocamldocsrc{latex}{"odoc_latex.ml"},
+\item for TeXinfo~: \ocamldocsrc{texi}{"odoc_texi.ml"},
+\item for man pages~: \ocamldocsrc{man}{"odoc_man.ml"},
+\item for graphviz (dot)~: \ocamldocsrc{dot}{"odoc_dot.ml"}.
+\end{itemize}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%
+\subsection{Handling custom tags}
+\label{s:ocamldoc-handling-custom-tags}
+
+Making a custom generator handle custom tags (see
+\ref{s:ocamldoc-custom-tags}) is very simple.
+
+\subsubsection*{For HTML}
+Here is how to develop a HTML generator handling your custom tags.
+
+The class "Odoc_html.Generator.html" inherits
+from the class "Odoc_html.info", containing a field "tag_functions" which is a
+list pairs composed of a custom tag (e.g. "\"foo\"") and a function taking
+a "text" and returning HTML code (of type "string").
+To handle a new tag "bar", extend the current HTML generator
+ and complete the "tag_functions" field:
+\begin{verbatim}
+module Generator (G : Odoc_html.Html_generator) =
+struct
+ class html =
+ object(self)
+ inherit G.html
+
+ (** Return HTML code for the given text of a bar tag. *)
+ method html_of_bar t = (* your code here *)
+
+ initializer
+ tag_functions <- ("bar", self#html_of_bar) :: tag_functions
+ end
+end
+let _ = Odoc_args.extend_html_generator (module Generator : Odoc_gen.Html_functor);;
+\end{verbatim}
+
+Another method of the class "Odoc_html.info" will look for the
+function associated to a custom tag and apply it to the text given to
+the tag. If no function is associated to a custom tag, then the method
+prints a warning message on "stderr".
+
+\subsubsection{For other generators}
+You can act the same way for other kinds of generators.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%
+\section{Adding command line options}
+The command line analysis is performed after loading the module containing the
+documentation generator, thus allowing command line options to be added to the
+ list of existing ones. Adding an option can be done with the function
+\begin{verbatim}
+ Odoc_args.add_option : string * Arg.spec * string -> unit
+\end{verbatim}
+\noindent{}Note: Existing command line options can be redefined using
+this function.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%
+\subsection{Compilation and usage}
+\label{s:ocamldoc-compilation-and-usage}
+
+%%%%%%%%%%%%%%
+\subsubsection{Defining a custom generator class in one file}
+Let "custom.ml" be the file defining a new generator class.
+Compilation of "custom.ml" can be performed by the following command~:
+\begin{alltt}
+ ocamlc -I +ocamldoc -c custom.ml
+\end{alltt}
+\noindent{}The file "custom.cmo" is created and can be used this way~:
+\begin{alltt}
+ ocamldoc -g custom.cmo \var{other-options} \var{source-files}
+\end{alltt}
+\noindent{}Options selecting a built-in generator to "ocamldoc", such as
+"-html", have no effect if a custom generator of the same kind is provided using
+"-g". If the kinds do not match, the selected built-in generator is used and the
+custom one is ignored.
+
+%%%%%%%%%%%%%%
+\subsubsection{Defining a custom generator class in several files}
+It is possible to define a generator class in several modules, which
+are defined in several files \var{\nth{file}{1}}".ml"["i"],
+\var{\nth{file}{2}}".ml"["i"], ..., \var{\nth{file}{n}}".ml"["i"]. A ".cma"
+library file must be created, including all these files.
+
+The following commands create the "custom.cma" file from files
+\var{\nth{file}{1}}".ml"["i"], ..., \var{\nth{file}{n}}".ml"["i"]~:
+\begin{alltt}
+ocamlc -I +ocamldoc -c \var{\nth{file}{1}}.ml\textrm{[}i\textrm{]}
+ocamlc -I +ocamldoc -c \var{\nth{file}{2}}.ml\textrm{[}i\textrm{]}
+...
+ocamlc -I +ocamldoc -c \var{\nth{file}{n}}.ml\textrm{[}i\textrm{]}
+ocamlc -o custom.cma -a \var{\nth{file}{1}}.cmo \var{\nth{file}{2}}.cmo ... \var{\nth{file}{n}}.cmo
+\end{alltt}
+\noindent{}Then, the following command uses "custom.cma" as custom generator:
+\begin{alltt}
+ ocamldoc -g custom.cma \var{other-options} \var{source-files}
+\end{alltt}
--- /dev/null
+\chapter{Compiler plugins\label{c:plugins}}
+\pdfchapterfold{-9}{Compiler plugind}
+%HEVEA\cutname{plugins.html}
+
+\section{Overview}
+
+Starting from OCaml 4.03, it is possible to extend the native and bytecode compilers
+with plugins using the "-plugin" command line option of both tools.
+This possibility is also available for "ocamldep" for OCaml version ulterior to 4.05.
+Beware however that plugins are an advanced feature of which the design
+is still in flux and breaking changes may happen in the future. Plugins features
+are based on the compiler library API. In complement, new hooks have been added to
+the compiler to increase its flexibility.
+
+In particular, hooks are available in the
+\ifouthtml\ahref{libref/Pparse.html}{\texttt{Pparse} module}
+\else\texttt{Pparse} module (see section~\ref{Pparse})\fi
+to transform the parsed abstract syntax tree, providing similar functionality
+to extension point based preprocessors.
+Other hooks are available to analyze the typed tree in the
+\ifouthtml\ahref{libref/Typemod.html}{\texttt{Typemod} module}
+\else\texttt{Typemod} module (see section~\ref{Typemod})\fi
+after the type-checking phase of the compiler. Since the typed tree relies
+on numerous invariants that play a vital part in ulterior phases of the
+compiler, it is not possible however to transform the typed tree.
+Similarly, the intermediary lambda representation can be modified by using the
+hooks provided in the
+\ifouthtml\ahref{libref/Simplif.html}{\texttt{Simplif} module}
+\else\texttt{Simplif} module (see section~\ref{Simplif})\fi.
+A plugin can also add new options to a tool through the
+"Clflags.add_arguments" function (see
+\ifouthtml\ahref{libref/Clflags.html}{\texttt{Clflags} module}
+\else\texttt{Clflags} module (see section~\ref{Clflags})\fi).
+
+Plugins are dynamically loaded and need to be compiled in the same mode (i.e.
+native or bytecode) that the tool they extend.
+
+\section{Basic example}
+
+As an illustration, we shall build a simple "Hello world" plugin that adds
+a simple statement "print_endline \"Hello from:$sourcefile\"" to a compiled file.
+
+The simplest way to implement this feature is to modify the abstract syntax
+tree. We will therefore add an hooks to the "Pparse.ImplementationHooks".
+Since the proposed modification is very basic, we could implement the hook
+directly. However, for the sake of this illustration, we use the "Ast_mapper"
+structure that provides a better path to build more interesting plugins.
+
+The first step is to build the AST fragment corresponding to the
+evaluation of "print_endline":
+\begin{verbatim}
+ let print_endline name =
+ let open Ast_helper in
+ let print_endline = Exp.ident
+ @@ Location.mknoloc @@Longident.Lident "print_endline" in
+ let hello = Exp.constant @@ Const.string @@ "Hello from: " ^ name in
+ Str.eval @@ Exp.apply print_endline [Asttypes.Nolabel, hello]
+\end{verbatim}%
+Then, we can construct an ast mapper that adds this fragment to the parsed
+ast tree.
+\begin{verbatim}
+let add_hello name (mapper:Ast_mapper.mapper) structure =
+ let default = Ast_mapper.default_mapper in
+ (print_endline name) :: (default.structure default structure)
+
+let ast_mapper name =
+ { Ast_mapper.default_mapper with structure = add_hello name }
+\end{verbatim}%
+%
+Once this AST mapper is constructed, we need to convert it to a hook and adds this
+hook to the "Pparse.ImplementationsHooks".
+\begin{verbatim}
+let transform hook_info structure =
+ let astm = ast_mapper hook_info.Misc.sourcefile in
+ astm.structure astm structure
+
+let () = Pparse.ImplementationHooks.add_hook "Hello world hook" transform
+\end{verbatim}
+%
+The resulting simplistic plugin can then be compiled with
+\begin{verbatim}
+$ ocamlopt -I +compiler-libs -shared plugin.ml -o plugin.cmxs
+\end{verbatim}
+%
+Compiling other files with this plugin enabled is then as simple as
+\begin{verbatim}
+$ ocamlopt -plugin plugin.cmxs test.ml -o test
+\end{verbatim}
--- /dev/null
+\chapter{Profiling (ocamlprof)} \label{c:profiler}
+\pdfchapter{Profiling (ocamlprof)}
+%HEVEA\cutname{profil.html}
+
+This chapter describes how the execution of OCaml
+programs can be profiled, by recording how many times functions are
+called, branches of conditionals are taken, \ldots
+
+\section{Compiling for profiling}
+
+Before profiling an execution, the program must be compiled in
+profiling mode, using the "ocamlcp" front-end to the "ocamlc" compiler
+(see chapter~\ref{c:camlc}) or the "ocamloptp" front-end to the
+"ocamlopt" compiler (see chapter~\ref{c:nativecomp}). When compiling
+modules separately, "ocamlcp" or "ocamloptp" must be used when
+compiling the modules (production of ".cmo" or ".cmx" files), and can
+also be used (though this is not strictly necessary) when linking them
+together.
+
+\paragraph{Note} If a module (".ml" file) doesn't have a corresponding
+interface (".mli" file), then compiling it with "ocamlcp" will produce
+object files (".cmi" and ".cmo") that are not compatible with the ones
+produced by "ocamlc", which may lead to problems (if the ".cmi" or
+".cmo" is still around) when switching between profiling and
+non-profiling compilations. To avoid this problem, you should always
+have a ".mli" file for each ".ml" file. The same problem exists with
+"ocamloptp".
+
+\paragraph{Note} To make sure your programs can be compiled in
+profiling mode, avoid using any identifier that begins with
+"__ocaml_prof".
+
+The amount of profiling information can be controlled through the "-P"
+option to "ocamlcp" or "ocamloptp", followed by one or several letters
+indicating which parts of the program should be profiled:
+
+%% description des options
+\begin{options}
+\item["a"] all options
+\item["f"] function calls : a count point is set at the beginning of
+each function body
+\item["i"] {\bf if \ldots then \ldots else \ldots} : count points are set in
+both {\bf then} branch and {\bf else} branch
+\item["l"] {\bf while, for} loops: a count point is set at the beginning of
+the loop body
+\item["m"] {\bf match} branches: a count point is set at the beginning of the
+body of each branch
+\item["t"] {\bf try \ldots with \ldots} branches: a count point is set at the
+beginning of the body of each branch
+\end{options}
+
+For instance, compiling with "ocamlcp -P film" profiles function calls,
+if\ldots then\ldots else\ldots, loops and pattern matching.
+
+Calling "ocamlcp" or "ocamloptp" without the "-P" option defaults to
+"-P fm", meaning that only function calls and pattern matching are
+profiled.
+
+\paragraph{Note} For compatibility with previous releases, "ocamlcp"
+also accepts the "-p" option, with the same arguments and behaviour as
+"-P".
+
+The "ocamlcp" and "ocamloptp" commands also accept all the options of
+the corresponding "ocamlc" or "ocamlopt" compiler, except the "-pp"
+(preprocessing) option.
+
+
+\section{Profiling an execution}
+
+Running an executable that has been compiled with "ocamlcp" or
+"ocamloptp" records the execution counts for the specified parts of
+the program and saves them in a file called "ocamlprof.dump" in the
+current directory.
+
+If the environment variable "OCAMLPROF_DUMP" is set when the program
+exits, its value is used as the file name instead of "ocamlprof.dump".
+
+The dump file is written only if the program terminates
+normally (by calling "exit" or by falling through). It is not written
+if the program terminates with an uncaught exception.
+
+If a compatible dump file already exists in the current directory, then the
+profiling information is accumulated in this dump file. This allows, for
+instance, the profiling of several executions of a program on
+different inputs. Note that dump files produced by byte-code
+executables (compiled with "ocamlcp") are compatible with the dump
+files produced by native executables (compiled with "ocamloptp").
+
+\section{Printing profiling information}
+
+The "ocamlprof" command produces a source listing of the program modules
+where execution counts have been inserted as comments. For instance,
+\begin{verbatim}
+ ocamlprof foo.ml
+\end{verbatim}
+prints the source code for the "foo" module, with comments indicating
+how many times the functions in this module have been called. Naturally,
+this information is accurate only if the source file has not been modified
+after it was compiled.
+
+The following options are recognized by "ocamlprof":
+
+\begin{options}
+
+\item["-args" \var{filename}]
+ Read additional newline-terminated command line arguments from \var{filename}.
+
+\item["-args0" \var{filename}]
+ Read additional null character terminated command line arguments from \var{filename}.
+
+\item["-f" \var{dumpfile}]
+Specifies an alternate dump file of profiling information to be read.
+
+\item["-F" \var{string}]
+Specifies an additional string to be output with profiling information.
+By default, "ocamlprof" will annotate programs with comments of the form
+{\tt (* \var{n} *)} where \var{n} is the counter value for a profiling
+point. With option {\tt -F \var{s}}, the annotation will be
+{\tt (* \var{s}\var{n} *)}.
+
+\item["-impl" \var{filename}]
+Process the file \var{filename} as an implementation file, even if its
+extension is not ".ml".
+
+\item["-intf" \var{filename}]
+Process the file \var{filename} as an interface file, even if its
+extension is not ".mli".
+
+\item["-version"]
+Print version string and exit.
+
+\item["-vnum"]
+Print short version number and exit.
+
+\item["-help" or "--help"]
+Display a short usage summary and exit.
+%
+\end{options}
+
+\section{Time profiling}
+
+Profiling with "ocamlprof" only records execution counts, not the actual
+time spent within each function. There is currently no way to perform
+time profiling on bytecode programs generated by "ocamlc".
+
+Native-code programs generated by "ocamlopt" can be profiled for time
+and execution counts using the "-p" option and the standard Unix
+profiler "gprof". Just add the "-p" option when compiling and linking
+the program:
+\begin{alltt}
+ ocamlopt -o myprog -p \var{other-options} \var{files}
+ ./myprog
+ gprof myprog
+\end{alltt}
+OCaml function names in the output of "gprof" have the following format:
+\begin{alltt}
+ \var{Module-name}_\var{function-name}_\var{unique-number}
+\end{alltt}
+Other functions shown are either parts of the OCaml run-time system or
+external C functions linked with the program.
+
+The output of "gprof" is described in the Unix manual page for
+"gprof(1)". It generally consists of two parts: a ``flat'' profile
+showing the time spent in each function and the number of invocation
+of each function, and a ``hierarchical'' profile based on the call
+graph. Currently, only the Intel x86 ports of "ocamlopt" under
+Linux, BSD and MacOS X support the two profiles. On other platforms,
+"gprof" will report only the ``flat'' profile with just time
+information. When reading the output of "gprof", keep in mind that
+the accumulated times computed by "gprof" are based on heuristics and
+may not be exact.
+
+\paragraph{Note} The "ocamloptp" command also accepts the "-p"
+option. In that case, both kinds of profiling are performed by the
+program, and you can display the results with the "gprof" and "ocamlprof"
+commands, respectively.
--- /dev/null
+\chapter{The runtime system (ocamlrun)} \label{c:runtime}
+\pdfchapter{The runtime system (ocamlrun)}
+%HEVEA\cutname{runtime.html}
+
+The "ocamlrun" command executes bytecode files produced by the
+linking phase of the "ocamlc" command.
+
+\section{Overview}
+
+The "ocamlrun" command comprises three main parts: the bytecode
+interpreter, that actually executes bytecode files; the memory
+allocator and garbage collector; and a set of C functions that
+implement primitive operations such as input/output.
+
+The usage for "ocamlrun" is:
+\begin{alltt}
+ ocamlrun \var{options} \var{bytecode-executable} \nth{arg}{1} ... \nth{arg}{n}
+\end{alltt}
+The first non-option argument is taken to be the name of the file
+containing the executable bytecode. (That file is searched in the
+executable path as well as in the current directory.) The remaining
+arguments are passed to the OCaml program, in the string array
+"Sys.argv". Element 0 of this array is the name of the
+bytecode executable file; elements 1 to \var{n} are the remaining
+arguments \nth{arg}{1} to \nth{arg}{n}.
+
+As mentioned in chapter~\ref{c:camlc}, the bytecode executable files
+produced by the "ocamlc" command are self-executable, and manage to
+launch the "ocamlrun" command on themselves automatically. That is,
+assuming "a.out" is a bytecode executable file,
+\begin{alltt}
+ a.out \nth{arg}{1} ... \nth{arg}{n}
+\end{alltt}
+works exactly as
+\begin{alltt}
+ ocamlrun a.out \nth{arg}{1} ... \nth{arg}{n}
+\end{alltt}
+Notice that it is not possible to pass options to "ocamlrun" when
+invoking "a.out" directly.
+
+\begin{windows}
+Under several versions of Windows, bytecode executable files are
+self-executable only if their name ends in ".exe". It is recommended
+to always give ".exe" names to bytecode executables, e.g. compile
+with "ocamlc -o myprog.exe ..." rather than "ocamlc -o myprog ...".
+\end{windows}
+
+\section{Options} \label{ocamlrun-options}
+
+The following command-line options are recognized by "ocamlrun".
+
+\begin{options}
+
+\item["-b"]
+When the program aborts due to an uncaught exception, print a detailed
+``back trace'' of the execution, showing where the exception was
+raised and which function calls were outstanding at this point. The
+back trace is printed only if the bytecode executable contains
+debugging information, i.e. was compiled and linked with the "-g"
+option to "ocamlc" set. This is equivalent to setting the "b" flag
+in the "OCAMLRUNPARAM" environment variable (see below).
+\item["-I" \var{dir}]
+Search the directory \var{dir} for dynamically-loaded libraries,
+in addition to the standard search path (see
+section~\ref{s-ocamlrun-dllpath}).
+\item["-p"]
+Print the names of the primitives known to this version of
+"ocamlrun" and exit.
+\item["-v"]
+Direct the memory manager to print some progress messages on
+standard error. This is equivalent to setting "v=63" in the
+"OCAMLRUNPARAM" environment variable (see below).
+\item["-version"]
+Print version string and exit.
+\item["-vnum"]
+Print short version number and exit.
+
+\end{options}
+
+\noindent
+The following environment variables are also consulted:
+
+\begin{options}
+\item["CAML_LD_LIBRARY_PATH"] Additional directories to search for
+ dynamically-loaded libraries (see section~\ref{s-ocamlrun-dllpath}).
+
+\item["OCAMLLIB"] The directory containing the OCaml standard
+ library. (If "OCAMLLIB" is not set, "CAMLLIB" will be used instead.)
+ Used to locate the "ld.conf" configuration file for
+ dynamic loading (see section~\ref{s-ocamlrun-dllpath}). If not set,
+ default to the library directory specified when compiling OCaml.
+
+\item["OCAMLRUNPARAM"] Set the runtime system options
+ and garbage collection parameters.
+ (If "OCAMLRUNPARAM" is not set, "CAMLRUNPARAM" will be used instead.)
+ This variable must be a sequence of parameter specifications separated
+ by commas.
+ A parameter specification is an option letter followed by an "="
+ sign, a decimal number (or an hexadecimal number prefixed by "0x"),
+ and an optional multiplier. The options are documented below;
+ the last six correspond to the fields of the
+ "control" record documented in
+\ifouthtml
+ \ahref{libref/Gc.html}{Module \texttt{Gc}}.
+\else
+ section~\ref{Gc}.
+\fi
+ \begin{options}
+ \item[b] (backtrace) Trigger the printing of a stack backtrace
+ when an uncaught exception aborts the program.
+ This option takes no argument.
+ \item[p] (parser trace) Turn on debugging support for
+ "ocamlyacc"-generated parsers. When this option is on,
+ the pushdown automaton that executes the parsers prints a
+ trace of its actions. This option takes no argument.
+ \item[R] (randomize) Turn on randomization of all hash tables by default
+ (see
+\ifouthtml
+ \ahref{libref/Hashtbl.html}{Module \texttt{Hashtbl}}).
+\else
+ section~\ref{Hashtbl}).
+\fi
+ This option takes no argument.
+ \item[h] The initial size of the major heap (in words).
+ \item[a] ("allocation_policy") The policy used for allocating in the
+ OCaml heap. Possible values are 0 for the next-fit policy, and 1
+ for the first-fit policy. Next-fit is usually faster, but first-fit
+ is better for avoiding fragmentation and the associated heap
+ compactions.
+ \item[s] ("minor_heap_size") Size of the minor heap. (in words)
+ \item[i] ("major_heap_increment") Default size increment for the
+ major heap. (in words)
+ \item[o] ("space_overhead") The major GC speed setting.
+ \item[O] ("max_overhead") The heap compaction trigger setting.
+ \item[l] ("stack_limit") The limit (in words) of the stack size.
+ \item[v] ("verbose") What GC messages to print to stderr. This
+ is a sum of values selected from the following:
+ \begin{options}
+ \item[1 (= 0x001)] Start of major GC cycle.
+ \item[2 (= 0x002)] Minor collection and major GC slice.
+ \item[4 (= 0x004)] Growing and shrinking of the heap.
+ \item[8 (= 0x008)] Resizing of stacks and memory manager tables.
+ \item[16 (= 0x010)] Heap compaction.
+ \item[32 (= 0x020)] Change of GC parameters.
+ \item[64 (= 0x040)] Computation of major GC slice size.
+ \item[128 (= 0x080)] Calling of finalization functions
+ \item[256 (= 0x100)] Startup messages (loading the bytecode
+ executable file, resolving shared libraries).
+ \item[512 (= 0x200)] Computation of compaction-triggering condition.
+ \item[1024 (= 0x400)] Output GC statistics at program exit.
+ \end{options}
+ \item[c] ("cleanup_on_exit") Shut the runtime down gracefully on exit (see
+ "caml_shutdown" in section~\ref{s:embedded-code}). The option also enables
+ pooling (as in "caml_startup_pooled"). This mode can be used to detect
+ leaks with a third-party memory debugger.
+ \end{options}
+ The multiplier is "k", "M", or "G", for multiplication by $2^{10}$,
+ $2^{20}$, and $2^{30}$ respectively.
+
+ If the option letter is not recognized, the whole parameter is ignored;
+ if the equal sign or the number is missing, the value is taken as 1;
+ if the multiplier is not recognized, it is ignored.
+
+ For example, on a 32-bit machine, under "bash" the command
+\begin{verbatim}
+ export OCAMLRUNPARAM='b,s=256k,v=0x015'
+\end{verbatim}
+ tells a subsequent "ocamlrun" to print backtraces for uncaught exceptions,
+ set its initial minor heap size to 1~megabyte and
+ print a message at the start of each major GC cycle, when the heap
+ size changes, and when compaction is triggered.
+
+\item["CAMLRUNPARAM"] If "OCAMLRUNPARAM" is not found in the
+ environment, then "CAMLRUNPARAM" will be used instead. If
+ "CAMLRUNPARAM" is also not found, then the default values will be used.
+
+\item["PATH"] List of directories searched to find the bytecode
+executable file.
+\end{options}
+
+\section{Dynamic loading of shared libraries} \label{s-ocamlrun-dllpath}
+
+On platforms that support dynamic loading, "ocamlrun" can link
+dynamically with C shared libraries (DLLs) providing additional C primitives
+beyond those provided by the standard runtime system. The names for
+these libraries are provided at link time as described in
+section~\ref{dynlink-c-code}), and recorded in the bytecode executable
+file; "ocamlrun", then, locates these libraries and resolves references
+to their primitives when the bytecode executable program starts.
+
+The "ocamlrun" command searches shared libraries in the following
+directories, in the order indicated:
+\begin{enumerate}
+\item Directories specified on the "ocamlrun" command line with the
+"-I" option.
+\item Directories specified in the "CAML_LD_LIBRARY_PATH" environment
+variable.
+\item Directories specified at link-time via the "-dllpath" option to
+"ocamlc". (These directories are recorded in the bytecode executable
+file.)
+\item Directories specified in the file "ld.conf". This file resides
+in the OCaml standard library directory, and lists directory
+names (one per line) to be searched. Typically, it contains only one
+line naming the "stublibs" subdirectory of the OCaml standard
+library directory. Users can add there the names of other directories
+containing frequently-used shared libraries; however, for consistency
+of installation, we recommend that shared libraries are installed
+directly in the system "stublibs" directory, rather than adding lines
+to the "ld.conf" file.
+\item Default directories searched by the system dynamic loader.
+Under Unix, these generally include "/lib" and "/usr/lib", plus the
+directories listed in the file "/etc/ld.so.conf" and the environment
+variable "LD_LIBRARY_PATH". Under Windows, these include the Windows
+system directories, plus the directories listed in the "PATH"
+environment variable.
+\end{enumerate}
+
+\section{Common errors}
+
+This section describes and explains the most frequently encountered
+error messages.
+
+\begin{options}
+
+\item[{\it filename}": no such file or directory"]
+If {\it filename} is the name of a self-executable bytecode file, this
+means that either that file does not exist, or that it failed to run
+the "ocamlrun" bytecode interpreter on itself. The second possibility
+indicates that OCaml has not been properly installed on your
+system.
+
+\item["Cannot exec ocamlrun"]
+(When launching a self-executable bytecode file.) The "ocamlrun"
+ could not be found in the executable path. Check that OCaml
+ has been properly installed on your system.
+
+\item["Cannot find the bytecode file"]
+The file that "ocamlrun" is trying to execute (e.g. the file given as
+first non-option argument to "ocamlrun") either does not exist, or is
+not a valid executable bytecode file.
+
+\item["Truncated bytecode file"]
+The file that "ocamlrun" is trying to execute is not a valid executable
+bytecode file. Probably it has been truncated or mangled since
+created. Erase and rebuild it.
+
+\item["Uncaught exception"]
+The program being executed contains a ``stray'' exception. That is,
+it raises an exception at some point, and this exception is never
+caught. This causes immediate termination of the program. The name of
+the exception is printed, along with its string, byte sequence, and
+integer arguments
+(arguments of more complex types are not correctly printed).
+To locate the context of the uncaught exception, compile the program
+with the "-g" option and either run it again under the "ocamldebug"
+debugger (see chapter~\ref{c:debugger}), or run it with "ocamlrun -b"
+or with the "OCAMLRUNPARAM" environment variable set to "b=1".
+
+\item["Out of memory"]
+The program being executed requires more memory than available. Either
+the program builds excessively large data structures; or the program
+contains too many nested function calls, and the stack overflows. In
+some cases, your program is perfectly correct, it just requires more
+memory than your machine provides. In other cases, the ``out of
+memory'' message reveals an error in your program: non-terminating
+recursive function, allocation of an excessively large array,
+string or byte sequence, attempts to build an infinite list or other
+data structure, \ldots
+
+To help you diagnose this error, run your program with the "-v" option
+to "ocamlrun", or with the "OCAMLRUNPARAM" environment variable set to
+"v=63". If it displays lots of ``"Growing stack"\ldots''
+messages, this is probably a looping recursive function. If it
+displays lots of ``"Growing heap"\ldots'' messages, with the heap size
+growing slowly, this is probably an attempt to construct a data
+structure with too many (infinitely many?) cells. If it displays few
+``"Growing heap"\ldots'' messages, but with a huge increment in the
+heap size, this is probably an attempt to build an excessively large
+array, string or byte sequence.
+
+\end{options}
--- /dev/null
+\chapter{Memory profiling with Spacetime}
+\pdfchapterfold{-9}{Memory profiling with Spacetime}
+%HEVEA\cutname{spacetime.html}
+
+\section{Overview}
+
+Spacetime is the name given to functionality within the OCaml compiler that
+provides for accurate profiling of the memory behaviour of a program.
+Using Spacetime it is possible to determine the source of memory leaks
+and excess memory allocation quickly and easily. Excess allocation slows
+programs down both by imposing a higher load on the garbage collector and
+reducing the cache locality of the program's code. Spacetime provides
+full backtraces for every allocation that occurred on the OCaml heap
+during the lifetime of the program including those in C stubs.
+
+Spacetime only analyses the memory behaviour of a program with respect to
+the OCaml heap allocators and garbage collector. It does not analyse
+allocation on the C heap. Spacetime does not affect the memory behaviour
+of a program being profiled with the exception of any change caused by the
+overhead of profiling (see section\ \ref{runtimeoverhead})---for example
+the program running slower might cause it to allocate less memory in total.
+
+Spacetime is currently only available for x86-64 targets and has only been
+tested on Linux systems (although it is expected to work on most modern
+Unix-like systems and provision has been made for running under
+Windows). It is expected that the set of supported platforms will
+be extended in the future.
+
+\section{How to use it}
+
+\subsection{Building}
+
+To use Spacetime it is necessary to use an OCaml compiler that was
+configured with the {\tt -spacetime} option. It is not possible to select
+Spacetime on a per-source-file basis or for a subset of files in a project;
+all files involved in the executable being profiled must be built with the
+Spacetime compiler. Only native code compilation is supported (not
+bytecode).
+
+If the {\tt libunwind} library is not available on the system then it will
+not be possible for Spacetime to profile allocations occurring within
+C stubs. If the {\tt libunwind} library is available but in an unusual
+location then that location may be specified to the {\tt configure} script
+using the {\tt -libunwinddir} option (or alternatively, using separate
+{\tt -libunwindinclude} and {\tt -libunwindlib} options).
+
+OPAM switches will be provided for Spacetime-configured compilers.
+
+Once the appropriate compiler has been selected the program should be
+built as normal (ensuring that all files are built with the Spacetime
+compiler---there is currently no protection to ensure this is the case, but
+it is essential). For many uses it will not be necessary to change the
+code of the program to use the profiler.
+
+Spacetime-configured compilers run slower and occupy more memory than their
+counterparts. It is hoped this will be fixed in the future as part of
+improved cross compilation support.
+
+\subsection{Running}
+
+Programs built with Spacetime instrumentation have a dependency on
+the {\tt libunwind} library unless that was unavailable at configure time or
+the {\tt -disable-libunwind} option was specified
+(see section\ \ref{runtimeoverhead}).
+
+Setting the {\tt OCAML\_SPACETIME\_INTERVAL} environment variable to an
+integer representing a number of milliseconds before running a program built
+with Spacetime will cause memory profiling to be in operation when the
+program is started. The contents of the OCaml heap will be sampled each
+time the number of milliseconds that the program has spent executing since the
+last sample exceeds the given number. (Note that the time base is combined
+user plus system time---{\em not} wall clock time. This peculiarity may be
+changed in future.)
+
+The program being profiled must exit normally or be caused to exit using
+the {\tt SIGINT} signal (e.g. by pressing Ctrl+C). When the program exits
+files will be written in the directory that was the working directory when
+the program was started. One Spacetime file will be written for each
+process that was involved, indexed by process ID; there will normally only
+be one such. The Spacetime files may be substantial. The directory to which
+they are written may be overridden by setting
+the {\tt OCAML\_SPACETIME\_SNAPSHOT\_DIR} environment variable before the
+program is started.
+
+Instead of using the automatic snapshot facility described above it is also
+possible to manually control Spacetime profiling. (The environment variables
+{\tt OCAML\_SPACETIME\_INTERVAL} and {\tt OCAML\_SPACETIME\_SNAPSHOT\_DIR}
+are then not relevant.) Full documentation as regards this method of profiling
+is provided in the standard library documentation (section\ \ref{c:stdlib})
+for the {\tt Spacetime} module.
+
+\subsection{Analysis}
+
+The compiler distribution does not itself provide the facility for analysing
+Spacetime output files; this is left to external tools. The first such tool
+will appear in OPAM as a package called {\tt prof_spacetime}. That tool will
+provide interactive graphical and terminal-based visualisation of
+the results of profiling.
+
+\section{Runtime overhead}\label{runtimeoverhead}
+
+The runtime overhead imposed by Spacetime varies considerably depending on
+the particular program being profiled. The overhead may be as low as
+ten percent---but more usually programs should be expected to run at perhaps
+a third or quarter of their normal speed. It is expected that this overhead
+will be reduced in future versions of the compiler.
+
+Execution speed of instrumented programs may be increased by using a compiler
+configured with the {\tt -disable-libunwind} option. This prevents collection
+of profiling information from C stubs.
+
+Programs running with Spacetime instrumentation consume significantly more
+memory than their non-instrumented counterparts. It is expected that this
+memory overhead will also be reduced in the future.
+
+\section{For developers}
+
+The compiler distribution provides an ``{\tt otherlibs}'' library called
+{\tt raw\_spacetime\_lib} for decoding Spacetime files. This library
+provides facilities to read not only memory profiling information but also
+the full dynamic call graph of the profiled program which is written into
+Spacetime output files.
+
+A library package {\tt spacetime\_lib} will be provided in OPAM
+to provide an interface for decoding profiling information at a higher
+level than that provided by {\tt raw\_spacetime\_lib}.
--- /dev/null
+\chapter{The toplevel system or REPL (ocaml)} \label{c:camllight}
+\pdfchapter{The toplevel system or REPL (ocaml)}
+%HEVEA\cutname{toplevel.html}
+
+This chapter describes the toplevel system for OCaml, that permits
+interactive use of the OCaml system
+through a read-eval-print loop (REPL). In this mode, the system repeatedly
+reads OCaml phrases from the input, then typechecks, compile and
+evaluate them, then prints the inferred type and result value, if
+any. The system prints a "#" (sharp) prompt before reading each
+phrase.
+
+Input to the toplevel can span several lines. It is terminated by @";;"@ (a
+double-semicolon). The toplevel input consists in one or several
+toplevel phrases, with the following syntax:
+
+\begin{syntax}
+toplevel-input:
+ {{ definition }} ';;'
+ | expr ';;'
+ | '#' ident [ directive-argument ] ';;'
+;
+directive-argument:
+ string-literal
+ | integer-literal
+ | value-path
+ | 'true' || 'false'
+\end{syntax}
+
+A phrase can consist of a definition, like those found in
+implementations of compilation units or in @'struct' \ldots 'end'@
+module expressions. The definition can bind value names, type names,
+an exception, a module name, or a module type name. The toplevel
+system performs the bindings, then prints the types and values (if
+any) for the names thus defined.
+
+A phrase may also consist in a value expression
+(section~\ref{s:value-expr}). It is simply evaluated
+without performing any bindings, and its value is
+printed.
+
+Finally, a phrase can also consist in a toplevel directive,
+starting with @"#"@ (the sharp sign). These directives control the
+behavior of the toplevel; they are listed below in
+section~\ref{s:toplevel-directives}.
+
+\begin{unix}
+The toplevel system is started by the command "ocaml", as follows:
+\begin{alltt}
+ ocaml \var{options} \var{objects} # interactive mode
+ ocaml \var{options} \var{objects} \var{scriptfile} # script mode
+\end{alltt}
+\var{options} are described below.
+\var{objects} are filenames ending in ".cmo" or ".cma"; they are
+loaded into the interpreter immediately after \var{options} are set.
+\var{scriptfile} is any file name not ending in ".cmo" or ".cma".
+
+If no \var{scriptfile} is given on the command line, the toplevel system
+enters interactive mode: phrases are read on standard input, results
+are printed on standard output, errors on standard error. End-of-file
+on standard input terminates "ocaml" (see also the "#quit" directive
+in section~\ref{s:toplevel-directives}).
+
+On start-up (before the first phrase is read), if the file
+".ocamlinit" exists in the current directory,
+its contents are read as a sequence of OCaml phrases
+and executed as per the "#use" directive
+described in section~\ref{s:toplevel-directives}.
+The evaluation outcode for each phrase are not displayed.
+If the current directory does not contain an ".ocamlinit" file, but
+the user's home directory (environment variable "HOME") does, the
+latter is read and executed as described below.
+
+The toplevel system does not perform line editing, but it can
+easily be used in conjunction with an external line editor such as
+"ledit", "ocaml2" or "rlwrap"
+\begin{latexonly}
+(see the Caml Hump "http://caml.inria.fr/humps/index_framed_caml.html").
+\end{latexonly}
+\begin{htmlonly}
+(see the
+\ahref{http://caml.inria.fr/humps/index\_framed\_caml.html}{Caml Hump}).
+\end{htmlonly}
+Another option is to use "ocaml" under Gnu Emacs, which gives the
+full editing power of Emacs (command "run-caml" from library "inf-caml").
+
+At any point, the parsing, compilation or evaluation of the current
+phrase can be interrupted by pressing "ctrl-C" (or, more precisely,
+by sending the "INTR" signal to the "ocaml" process). The toplevel
+then immediately returns to the "#" prompt.
+
+If \var{scriptfile} is given on the command-line to "ocaml", the toplevel
+system enters script mode: the contents of the file are read as a
+sequence of OCaml phrases and executed, as per the "#use"
+directive (section~\ref{s:toplevel-directives}). The outcome of the
+evaluation is not printed. On reaching the end of file, the "ocaml"
+command exits immediately. No commands are read from standard input.
+"Sys.argv" is transformed, ignoring all OCaml parameters, and
+starting with the script file name in "Sys.argv.(0)".
+
+In script mode, the first line of the script is ignored if it starts
+with "#!". Thus, it should be possible to make the script
+itself executable and put as first line "#!/usr/local/bin/ocaml",
+thus calling the toplevel system automatically when the script is
+run. However, "ocaml" itself is a "#!" script on most installations
+of OCaml, and Unix kernels usually do not handle nested "#!"
+scripts. A better solution is to put the following as the first line
+of the script:
+\begin{verbatim}
+ #!/usr/local/bin/ocamlrun /usr/local/bin/ocaml
+\end{verbatim}
+
+\end{unix}
+
+\section{Options} \label{s:toplevel-options}
+
+The following command-line options are recognized by the "ocaml" command.
+% Configure boolean variables used by the macros in unified-options.etex
+\compfalse
+\natfalse
+\toptrue
+% unified-options gathers all options across the native/bytecode
+% compilers and toplevel
+\input{unified-options.tex}
+
+\begin{unix}
+The following environment variables are also consulted:
+\begin{options}
+\item["OCAMLTOP_UTF_8"] When printing string values, non-ascii bytes
+($ {} > "\0x7E" $) are printed as decimal escape sequence if "OCAMLTOP_UTF_8" is
+set to false. Otherwise, they are printed unescaped.
+
+\item["TERM"] When printing error messages, the toplevel system
+attempts to underline visually the location of the error. It
+consults the "TERM" variable to determines the type of output terminal
+and look up its capabilities in the terminal database.
+
+\item["HOME"] Directory where the ".ocamlinit" file is searched.
+\end{options}
+\end{unix}
+
+\section{Toplevel directives}
+\label{s:toplevel-directives}
+
+The following directives control the toplevel behavior, load files in
+memory, and trace program execution.
+
+{\bf Note:} all directives start with a "#" (sharp) symbol. This "#"
+must be typed before the directive, and must not be confused with the
+"#" prompt displayed by the interactive loop. For instance,
+typing "#quit;;" will exit the toplevel loop, but typing "quit;;"
+will result in an ``unbound value "quit"'' error.
+
+%
+% Remark: this list of options should be kept synchronized with the documentation
+% in toplevel/topdirs.ml.
+%
+\begin{options}
+\item[General]
+ \begin{options}
+ \item["#help;;"]
+ Prints a list of all available directives, with corresponding argument type
+ if appropriate.
+ \item["#quit;;"]
+ Exit the toplevel loop and terminate the "ocaml" command.
+ \end{options}
+
+\item[Loading codes]
+ \begin{options}
+
+ \item["#cd \""\var{dir-name}"\";;"]
+ Change the current working directory.
+
+ \item["#directory \""\var{dir-name}"\";;"]
+ Add the given directory to the list of directories searched for
+ source and compiled files.
+
+ \item["#remove_directory \""\var{dir-name}"\";;"]
+ Remove the given directory from the list of directories searched for
+ source and compiled files. Do nothing if the list does not contain
+ the given directory.
+
+ \item["#load \""\var{file-name}"\";;"]
+ Load in memory a bytecode object file (".cmo" file) or library file
+ (".cma" file) produced by the batch compiler "ocamlc".
+
+ \item["#load_rec \""\var{file-name}"\";;"]
+ Load in memory a bytecode object file (".cmo" file) or library file
+ (".cma" file) produced by the batch compiler "ocamlc".
+ When loading an object file that depends on other modules
+ which have not been loaded yet, the .cmo files for these modules
+ are searched and loaded as well, recursively. The loading order
+ is not specified.
+
+ \item["#use \""\var{file-name}"\";;"]
+ Read, compile and execute source phrases from the given file.
+ This is textual inclusion: phrases are processed just as if
+ they were typed on standard input. The reading of the file stops at
+ the first error encountered.
+
+ \item["#mod_use \""\var{file-name}"\";;"]
+ Similar to "#use" but also wrap the code into a top-level module of the
+ same name as capitalized file name without extensions, following
+ semantics of the compiler.
+ \end{options}
+
+For directives that take file names as arguments, if the given file
+name specifies no directory, the file is searched in the following
+directories:
+\begin{enumerate}
+ \item In script mode, the directory containing the script currently
+ executing; in interactive mode, the current working directory.
+ \item Directories added with the "#directory" directive.
+ \item Directories given on the command line with "-I" options.
+ \item The standard library directory.
+\end{enumerate}
+
+\item[Environment queries]
+ \begin{options}
+ \item["#show_class "\var{class-path}";;"]\vspace{-4.7ex}
+ \item["#show_class_type "\var{class-path}";;"]\vspace{-4.7ex}
+ \item["#show_exception "\var{ident}";;"]\vspace{-4.7ex}
+ \item["#show_module "\var{module-path}";;"]\vspace{-4.7ex}
+ \item["#show_module_type "\var{modtype-path}";;"]\vspace{-4.7ex}
+ \item["#show_type "\var{typeconstr}";;"]\vspace{-4.7ex}
+ \item["#show_val "\var{value-path}";;"]
+ Print the signature of the corresponding component.
+
+ \item["#show "\var{ident}";;"]
+ Print the signatures of components with name \var{ident} in all the
+ above categories.
+ \end{options}
+
+\item[Pretty-printing]
+ \begin{options}
+
+ \item["#install_printer "\var{printer-name}";;"]
+ This directive registers the function named \var{printer-name} (a
+ value path) as a printer for values whose types match the argument
+ type of the function. That is, the toplevel loop will call
+ \var{printer-name} when it has such a value to print.
+
+ The printing function \var{printer-name} should have type
+ @"Format.formatter" "->" @t@ "->" "unit"@, where @@t@@ is the
+ type for the values to be printed, and should output its textual
+ representation for the value of type @@t@@ on the given formatter,
+ using the functions provided by the "Format" library. For backward
+ compatibility, \var{printer-name} can also have type
+ @@t@ "->" "unit"@ and should then output on the standard
+ formatter, but this usage is deprecated.
+
+ \item["#print_depth "\var{n}";;"]
+ Limit the printing of values to a maximal depth of \var{n}.
+ The parts of values whose depth exceeds \var{n} are printed as "..."
+ (ellipsis).
+
+ \item["#print_length "\var{n}";;"]
+ Limit the number of value nodes printed to at most \var{n}.
+ Remaining parts of values are printed as "..." (ellipsis).
+
+ \item["#remove_printer "\var{printer-name}";;"]
+ Remove the named function from the table of toplevel printers.
+\end{options}
+
+\item[Tracing]
+ \begin{options}
+ \item["#trace "\var{function-name}";;"]
+ After executing this directive, all calls to the function named
+ \var{function-name} will be ``traced''. That is, the argument and the
+ result are displayed for each call, as well as the exceptions escaping
+ out of the function, raised either by the function itself or by
+ another function it calls. If the function is curried, each argument
+ is printed as it is passed to the function.
+
+ \item["#untrace "\var{function-name}";;"]
+ Stop tracing the given function.
+
+ \item["#untrace_all;;"]
+ Stop tracing all functions traced so far.
+ \end{options}
+
+\item[Compiler options]
+ \begin{options}
+ \item["#labels "\var{bool}";;"]
+ Ignore labels in function types if argument is "false", or switch back
+ to default behaviour (commuting style) if argument is "true".
+
+ \item["#ppx \""\var{file-name}"\";;"]
+ After parsing, pipe the abstract syntax tree through the preprocessor
+ command.
+
+ \item["#principal "\var{bool}";;"]
+ If the argument is "true", check information paths during
+ type-checking, to make sure that all types are derived in a principal
+ way. If the argument is "false", do not check information paths.
+
+ \item["#rectypes;;"]
+ Allow arbitrary recursive types during type-checking. Note: once
+ enabled, this option cannot be disabled because that would lead to
+ unsoundness of the type system.
+
+ \item["#warn_error \""\var{warning-list}"\";;"]
+ Treat as errors the warnings enabled by the argument and as normal
+ warnings the warnings disabled by the argument.
+
+ \item["#warnings \""\var{warning-list}"\";;"]
+ Enable or disable warnings according to the argument.
+
+ \end{options}
+
+\end{options}
+
+\section{The toplevel and the module system} \label{s:toplevel-modules}
+
+Toplevel phrases can refer to identifiers defined in compilation units
+with the same mechanisms as for separately compiled units: either by
+using qualified names ("Modulename.localname"), or by using
+the "open" construct and unqualified names (see section~\ref{s:names}).
+
+However, before referencing another compilation unit, an
+implementation of that unit must be present in memory.
+At start-up, the toplevel system contains implementations for all the
+modules in the the standard library. Implementations for user modules
+can be entered with the "#load" directive described above. Referencing
+a unit for which no implementation has been provided
+results in the error "Reference to undefined global `...'".
+
+Note that entering "open "\var{Mod} merely accesses the compiled
+interface (".cmi" file) for \var{Mod}, but does not load the
+implementation of \var{Mod}, and does not cause any error if no
+implementation of \var{Mod} has been loaded. The error
+``reference to undefined global \var{Mod}'' will occur only when
+executing a value or module definition that refers to \var{Mod}.
+
+\section{Common errors}
+
+This section describes and explains the most frequently encountered
+error messages.
+
+\begin{options}
+
+\item[Cannot find file \var{filename}]
+The named file could not be found in the current directory, nor in the
+directories of the search path.
+
+If \var{filename} has the format \var{mod}".cmi", this
+means you have referenced the compilation unit \var{mod}, but its
+compiled interface could not be found. Fix: compile \var{mod}".mli" or
+\var{mod}".ml" first, to create the compiled interface \var{mod}".cmi".
+
+If \var{filename} has the format \var{mod}".cmo", this
+means you are trying to load with "#load" a bytecode object file that
+does not exist yet. Fix: compile \var{mod}".ml" first.
+
+If your program spans several directories, this error can also appear
+because you haven't specified the directories to look into. Fix: use
+the "#directory" directive to add the correct directories to the
+search path.
+
+\item[This expression has type \nth{t}{1}, but is used with type \nth{t}{2}]
+See section~\ref{s:comp-errors}.
+
+\item[Reference to undefined global \var{mod}]
+You have neglected to load in memory an implementation for a module
+with "#load". See section~\ref{s:toplevel-modules} above.
+
+\end{options}
+
+\section{Building custom toplevel systems: \texttt{ocamlmktop}}
+
+The "ocamlmktop" command builds OCaml toplevels that
+contain user code preloaded at start-up.
+
+The "ocamlmktop" command takes as argument a set of ".cmo" and ".cma"
+files, and links them with the object files that implement the OCaml toplevel.
+The typical use is:
+\begin{verbatim}
+ ocamlmktop -o mytoplevel foo.cmo bar.cmo gee.cmo
+\end{verbatim}
+This creates the bytecode file "mytoplevel", containing the OCaml toplevel
+system, plus the code from the three ".cmo"
+files. This toplevel is directly executable and is started by:
+\begin{verbatim}
+ ./mytoplevel
+\end{verbatim}
+This enters a regular toplevel loop, except that the code from
+"foo.cmo", "bar.cmo" and "gee.cmo" is already loaded in memory, just as
+if you had typed:
+\begin{verbatim}
+ #load "foo.cmo";;
+ #load "bar.cmo";;
+ #load "gee.cmo";;
+\end{verbatim}
+on entrance to the toplevel. The modules "Foo", "Bar" and "Gee" are
+not opened, though; you still have to do
+\begin{verbatim}
+ open Foo;;
+\end{verbatim}
+yourself, if this is what you wish.
+
+\subsection{Options}
+
+The following command-line options are recognized by "ocamlmktop".
+
+\begin{options}
+
+\item["-cclib" \var{libname}]
+Pass the "-l"\var{libname} option to the C linker when linking in
+``custom runtime'' mode. See the corresponding option for
+"ocamlc", in chapter~\ref{c:camlc}.
+
+\item["-ccopt" \var{option}]
+Pass the given option to the C compiler and linker, when linking in
+``custom runtime'' mode. See the corresponding option for
+"ocamlc", in chapter~\ref{c:camlc}.
+
+\item["-custom"]
+Link in ``custom runtime'' mode. See the corresponding option for
+"ocamlc", in chapter~\ref{c:camlc}.
+
+\item["-I" \var{directory}]
+Add the given directory to the list of directories searched for
+compiled object code files (".cmo" and ".cma").
+
+\item["-o" \var{exec-file}]
+Specify the name of the toplevel file produced by the linker.
+The default is "a.out".
+
+\end{options}
+
+\section{The native toplevel: \texttt{ocamlnat}\ (experimental)}
+
+{\bf This section describes a tool that is not yet officially supported %
+but may be found useful.}
+
+OCaml code executing in the traditional toplevel system uses the bytecode
+interpreter. When increased performance is required, or for testing
+programs that will only execute correctly when compiled to native code,
+the {\em native toplevel} may be used instead.
+
+For the majority of installations the native toplevel will not have been
+installed along with the rest of the OCaml toolchain. In such circumstances
+it will be necessary to build the OCaml distribution from source.
+From the built source tree of the distribution you may use
+{\tt make natruntop} to build and execute a native toplevel. (Alternatively
+{\tt make ocamlnat} can be used, which just performs the build step.)
+
+If the {\tt make install} command is run after having built the native
+toplevel then the {\tt ocamlnat} program (either from the source or the
+installation directory) may be invoked directly rather than using
+{\tt make natruntop}.
--- /dev/null
+%
+% This file describes the native/bytecode compiler and toplevel
+% options. Since specific options can exist in only a subset of
+% \{toplevel, bytecode compiler, native compiler \} and their description
+% might differ across this subset, this file uses macros to adapt the
+% description tool by tool:
+\long\def\comp#1{\ifcomp#1\else\fi}
+% \long is needed for multiparagraph macros
+\long\def\nat#1{\ifnat#1\else\fi}
+\long\def\top#1{\iftop#1\else\fi}
+\long\def\notop#1{\iftop\else#1\fi}
+% ( Note that the previous definitions relies on the three boolean values
+% \top, \nat and \comp. The manual section must therefore
+% set these boolean values accordingly.
+% )
+% The macros (\comp, \nat, \top) adds a supplementary text
+% if we are respectively in the (bytecode compiler, native compiler, toplevel)
+% section.
+% The toplevel options are quite different from the compilers' options.
+% It is therefore useful to have also a substractive \notop macro
+% that prints its content only outside of the topvel section
+%
+% For instance, to add an option "-foo" that applies to the native and
+% bytecode compiler, one can write
+% \notop{\item["-foo"]
+% ...
+% }
+%
+% Similarly, an option "-bar" only available in the native compiler
+% can be introduced with
+% \nat{\item["-bar"]
+% ...
+% }
+% These macros can be also used to add information that are only relevant to
+% some tools or differ slightly from one tool to another. For instance, we
+% define the following macro for the pairs cma/cmxa cmo/cmxo and ocamlc/ocamlopt
+%
+\def\cma{\comp{.cma}\nat{.cmxa}}
+\def\cmo{\comp{.cmo}\nat{.cmx}}
+\def\qcmo{{\machine\cmo}}
+\def\qcma{{\machine\cma}}
+\def\ocamlx{\comp{ocamlc}\nat{ocamlopt}}
+%
+%
+\begin{options}
+\notop{%
+\item["-a"]
+Build a library(\nat{".cmxa" and ".a"/".lib" files}\comp{".cma" file})
+with the object files (\nat{".cmx" and ".o"/".obj" files}\comp{ ".cmo" files})
+given on the command line, instead of linking them into an executable file.
+The name of the library must be set with the "-o" option.
+
+If \comp{"-custom", }"-cclib" or "-ccopt" options are passed on the command
+line, these options are stored in the resulting \qcma library. Then,
+linking with this library automatically adds back the \comp{"-custom", }
+"-cclib" and "-ccopt" options as if they had been provided on the
+command line, unless the "-noautolink" option is given.
+}%notop
+
+\item["-absname"]
+Force error messages to show absolute paths for file names.
+
+\notop{\item["-annot"]
+Dump detailed information about the compilation (types, bindings,
+tail-calls, etc). The information for file \var{src}".ml"
+is put into file \var{src}".annot". In case of a type error, dump
+all the information inferred by the type-checker before the error.
+The \var{src}".annot" file can be used with the emacs commands given in
+"emacs/caml-types.el" to display types and other annotations
+interactively.
+}%notop
+
+\item["-args" \var{filename}]
+Read additional newline-terminated command line arguments from \var{filename}.
+\top{It is not possible to pass a \var{scriptfile} via file to the toplevel.
+}%top
+\item["-args0" \var{filename}]
+ Read additional null character terminated command line arguments from \var{filename}.
+\top{It is not possible to pass a \var{scriptfile} via file to the toplevel.
+}%top
+
+
+\notop{\item["-bin-annot"]
+Dump detailed information about the compilation (types, bindings,
+tail-calls, etc) in binary format. The information for file \var{src}".ml"
+(resp. \var{src}".mli") is put into file \var{src}".cmt"
+(resp. \var{src}".cmti"). In case of a type error, dump
+all the information inferred by the type-checker before the error.
+The "*.cmt" and "*.cmti" files produced by "-bin-annot" contain
+more information and are much more compact than the files produced by
+"-annot".
+}%notop
+
+\notop{\item["-c"]
+Compile only. Suppress the linking phase of the
+compilation. Source code files are turned into compiled files, but no
+executable file is produced. This option is useful to
+compile modules separately.
+}%notop
+
+\notop{%
+\item["-cc" \var{ccomp}]
+Use \var{ccomp} as the C linker \nat{called to build the final executable }
+\comp{when linking in ``custom runtime'' mode (see the "-custom" option)}
+and as the C compiler for compiling ".c" source files.
+}%notop
+
+\notop{%
+\item["-cclib" "-l"\var{libname}]
+Pass the "-l"\var{libname} option to the \comp{C} linker
+\comp{when linking in ``custom runtime'' mode (see the "-custom" option)}.
+This causes the given C library to be linked with the program.
+}%notop
+
+\notop{%
+\item["-ccopt" \var{option}]
+Pass the given option to the C compiler and linker.
+\comp{When linking in ``custom runtime'' mode, for instance}%
+\nat{For instance,}%
+"-ccopt -L"\var{dir} causes the C linker to search for C libraries in
+directory \var{dir}.\comp{(See the "-custom" option.)}
+}%notop
+
+\notop{%
+\item["-color" \var{mode}]
+Enable or disable colors in compiler messages (especially warnings and errors).
+The following modes are supported:
+\begin{description}
+ \item["auto"] use heuristics to enable colors only if the output supports them (an ANSI-compatible tty terminal);
+ \item["always"] enable colors unconditionally;
+ \item["never"] disable color output.
+\end{description}
+The default setting is 'auto', and the current heuristic
+checks that the "TERM" environment variable exists and is
+not empty or "dumb", and that 'isatty(stderr)' holds.
+
+The environment variable "OCAML_COLOR" is considered if "-color" is not
+provided. Its values are auto/always/never as above.
+}%notop
+
+\comp{%
+\item["-compat-32"]
+Check that the generated bytecode executable can run on 32-bit
+platforms and signal an error if it cannot. This is useful when
+compiling bytecode on a 64-bit machine.
+}%comp
+
+\nat{%
+\item["-compact"]
+Optimize the produced code for space rather than for time. This
+results in slightly smaller but slightly slower programs. The default is to
+optimize for speed.
+}%nat
+
+\item["-config"]
+Print the version number of {\machine\ocamlx} and a detailed
+summary of its configuration, then exit.
+
+\comp{%
+\item["-custom"]
+Link in ``custom runtime'' mode. In the default linking mode, the
+linker produces bytecode that is intended to be executed with the
+shared runtime system, "ocamlrun". In the custom runtime mode, the
+linker produces an output file that contains both the runtime system
+and the bytecode for the program. The resulting file is larger, but it
+can be executed directly, even if the "ocamlrun" command is not
+installed. Moreover, the ``custom runtime'' mode enables static
+linking of OCaml code with user-defined C functions, as described in
+chapter~\ref{c:intf-c}.
+\begin{unix}
+Never use the "strip" command on executables produced by "ocamlc -custom",
+this would remove the bytecode part of the executable.
+\end{unix}
+\begin{unix}
+Security warning: never set the ``setuid'' or ``setgid'' bits on executables
+produced by "ocamlc -custom", this would make them vulnerable to attacks.
+\end{unix}
+}%comp
+
+\notop{%
+\item["-depend" \var{ocamldep-args}]
+Compute dependencies, as the "ocamldep" command would do. The remaining
+arguments are interpreted as if they were given to the "ocamldep" command.
+}%notop
+
+\comp{
+\item["-dllib" "-l"\var{libname}]
+Arrange for the C shared library "dll"\var{libname}".so"
+("dll"\var{libname}".dll" under Windows) to be loaded dynamically
+by the run-time system "ocamlrun" at program start-up time.
+}%comp
+
+\comp{\item["-dllpath" \var{dir}]
+Adds the directory \var{dir} to the run-time search path for shared
+C libraries. At link-time, shared libraries are searched in the
+standard search path (the one corresponding to the "-I" option).
+The "-dllpath" option simply stores \var{dir} in the produced
+executable file, where "ocamlrun" can find it and use it as
+described in section~\ref{s-ocamlrun-dllpath}.
+}%comp
+
+\notop{%
+\item["-for-pack" \var{module-path}]
+Generate an object file (\qcmo\nat{ and ".o"/".obj" files})
+that can later be included
+as a sub-module (with the given access path) of a compilation unit
+constructed with "-pack". For instance,
+{\machine\ocamlx\ -for-pack\ P\ -c\ A.ml}
+will generate {\machine a.\cmo}\nat{ and "a.o" files} that can
+later be used with {\machine \ocamlx\ -pack\ -o\ P\cmo\ a\cmo}.
+Note: you can still pack a module that was compiled without
+"-for-pack" but in this case exceptions will be printed with the wrong
+names.
+}%notop
+
+\notop{%
+\item["-g"]
+Add debugging information while compiling and linking. This option is
+required in order to \comp{be able to debug the program with "ocamldebug"
+(see chapter~\ref{c:debugger}), and to} produce stack backtraces when
+the program terminates on an uncaught exception (see
+section~\ref{ocamlrun-options}).
+}%notop
+
+\notop{%
+\item["-i"]
+Cause the compiler to print all defined names (with their inferred
+types or their definitions) when compiling an implementation (".ml"
+file). No compiled files (".cmo" and ".cmi" files) are produced.
+This can be useful to check the types inferred by the
+compiler. Also, since the output follows the syntax of interfaces, it
+can help in writing an explicit interface (".mli" file) for a file:
+just redirect the standard output of the compiler to a ".mli" file,
+and edit that file to remove all declarations of unexported names.
+}%notop
+
+\item["-I" \var{directory}]
+Add the given directory to the list of directories searched for
+\nat{compiled interface files (".cmi"), compiled object code files (".cmx"),
+and libraries (".cmxa").}
+\comp{compiled interface files (".cmi"), compiled object code files ".cmo",
+libraries (".cma") and C libraries specified with "-cclib -lxxx".}
+\top{source and compiled files.}
+By default, the current directory is searched first, then the standard
+library directory. Directories added with "-I" are searched after the
+current directory, in the order in which they were given on the command line,
+but before the standard library directory. See also option "-nostdlib".
+
+If the given directory starts with "+", it is taken relative to the
+standard library directory. For instance, "-I +unix" adds the
+subdirectory "unix" of the standard library to the search path.
+
+\top{%
+Directories can also be added to the list once
+the toplevel is running with the "#directory" directive
+(section~\ref{s:toplevel-directives}).
+}%top
+
+\top{%
+\item["-init" \var{file}]
+Load the given file instead of the default initialization file.
+The default file is ".ocamlinit" in the current directory if it
+exists, otherwise ".ocamlinit" in the user's home directory.
+}%top
+
+\notop{%
+\item["-impl" \var{filename}]
+Compile the file \var{filename} as an implementation file, even if its
+extension is not ".ml".
+}%notop
+
+\nat{%
+\item["-inline" \var{n}]
+Set aggressiveness of inlining to \var{n}, where \var{n} is a positive
+integer. Specifying "-inline 0" prevents all functions from being
+inlined, except those whose body is smaller than the call site. Thus,
+inlining causes no expansion in code size. The default aggressiveness,
+"-inline 1", allows slightly larger functions to be inlined, resulting
+in a slight expansion in code size. Higher values for the "-inline"
+option cause larger and larger functions to become candidate for
+inlining, but can result in a serious increase in code size.
+}%nat
+
+\notop{%
+\item["-intf" \var{filename}]
+Compile the file \var{filename} as an interface file, even if its
+extension is not ".mli".
+}%notop
+
+\notop{%
+\item["-intf-suffix" \var{string}]
+Recognize file names ending with \var{string} as interface files
+(instead of the default ".mli").
+}%\notop
+
+\item["-labels"]
+Labels are not ignored in types, labels may be used in applications,
+and labelled parameters can be given in any order. This is the default.
+
+\notop{%
+\item["-linkall"]
+Force all modules contained in libraries to be linked in. If this
+flag is not given, unreferenced modules are not linked in. When
+building a library (option "-a"), setting the "-linkall" option forces all
+subsequent links of programs involving that library to link all the
+modules contained in the library. When compiling a module (option
+"-c"), setting the "-linkall" option ensures that this module will
+always be linked if it is put in a library and this library is linked.
+}%notop
+
+\nat{%
+\item["-linscan"]
+Use linear scan register allocation. Compiling with this allocator is faster
+than with the usual graph coloring allocator, sometimes quite drastically so for
+long functions and modules. On the other hand, the generated code can be a bit
+slower.
+}%nat
+
+\comp{%
+\item["-make-runtime"]
+Build a custom runtime system (in the file specified by option "-o")
+incorporating the C object files and libraries given on the command
+line. This custom runtime system can be used later to execute
+bytecode executables produced with the
+"ocamlc -use-runtime" \var{runtime-name} option.
+See section~\ref{s:custom-runtime} for more information.
+}%comp
+
+\notop{%
+\item["-no-alias-deps"]
+Do not record dependencies for module aliases. See
+section~\ref{s:module-alias} for more information.
+}%notop
+
+\item["-no-app-funct"]
+Deactivates the applicative behaviour of functors. With this option,
+each functor application generates new types in its result and
+applying the same functor twice to the same argument yields two
+incompatible structures.
+
+\item["-noassert"]
+Do not compile assertion checks. Note that the special form
+"assert false" is always compiled because it is typed specially.
+\notop{This flag has no effect when linking already-compiled files.}
+
+\notop{%
+\item["-noautolink"]
+When linking \qcma libraries, ignore \comp{"-custom",} "-cclib" and "-ccopt"
+options potentially contained in the libraries (if these options were
+given when building the libraries). This can be useful if a library
+contains incorrect specifications of C libraries or C options; in this
+case, during linking, set "-noautolink" and pass the correct C
+libraries and options on the command line.
+}%
+
+\nat{%
+\item["-nodynlink"]
+Allow the compiler to use some optimizations that are valid only for code
+that is never dynlinked.
+}%nat
+
+\item["-nolabels"]
+Ignore non-optional labels in types. Labels cannot be used in
+applications, and parameter order becomes strict.
+
+\top{%
+\item["-noprompt"]
+Do not display any prompt when waiting for input.
+}%top
+
+\top{%
+\item["-nopromptcont"]
+Do not display the secondary prompt when waiting for continuation
+lines in multi-line inputs. This should be used e.g. when running
+"ocaml" in an "emacs" window.
+}%top
+
+\item["-nostdlib"]
+\top{%
+Do not include the standard library directory in the list of
+directories searched for source and compiled files.
+}%top
+\comp{%
+Do not include the standard library directory in the list of
+directories searched for
+compiled interface files (".cmi"), compiled object code files
+(".cmo"), libraries (".cma"), and C libraries specified with
+"-cclib -lxxx". See also option "-I".
+}%comp
+\nat{%
+Do not automatically add the standard library directory the list of
+directories searched for compiled interface files (".cmi"), compiled
+object code files (".cmx"), and libraries (".cmxa"). See also option
+"-I".
+}%nat
+
+\notop{%
+\item["-o" \var{exec-file}]
+Specify the name of the output file produced by the
+\nat{linker}\comp{compiler}. The
+default output name is "a.out" under Unix and "camlprog.exe" under
+Windows. If the "-a" option is given, specify the name of the library
+produced. If the "-pack" option is given, specify the name of the
+packed object file produced. If the "-output-obj" option is given,
+specify the name of the output file produced.
+\nat{If the "-shared" option is given, specify the name of plugin
+file produced.}
+\comp{If the "-c" option is given, specify the name of the object
+file produced for the {\em next} source file that appears on the
+command line.}
+}%notop
+
+\notop{%
+\item["-opaque"]
+When the native compiler compiles an implementation, by default it
+produces a ".cmx" file containing information for cross-module
+optimization. It also expects ".cmx" files to be present for the
+dependencies of the currently compiled source, and uses them for
+optimization. Since OCaml 4.03, the compiler will emit a warning if it
+is unable to locate the ".cmx" file of one of those dependencies.
+
+The "-opaque" option, available since 4.04, disables cross-module
+optimization information for the currently compiled unit. When
+compiling ".mli" interface, using "-opaque" marks the compiled ".cmi"
+interface so that subsequent compilations of modules that depend on it
+will not rely on the corresponding ".cmx" file, nor warn if it is
+absent. When the native compiler compiles a ".ml" implementation,
+using "-opaque" generates a ".cmx" that does not contain any
+cross-module optimization information.
+
+Using this option may degrade the quality of generated code, but it
+reduces compilation time, both on clean and incremental
+builds. Indeed, with the native compiler, when the implementation of
+a compilation unit changes, all the units that depend on it may need
+to be recompiled -- because the cross-module information may have
+changed. If the compilation unit whose implementation changed was
+compiled with "-opaque", no such recompilation needs to occur. This
+option can thus be used, for example, to get faster edit-compile-test
+feedback loops.
+}%notop
+
+\notop{%
+\item["-open" \var{Module}]
+Opens the given module before processing the interface or
+implementation files. If several "-open" options are given,
+they are processed in order, just as if
+the statements "open!" \var{Module1}";;" "..." "open!" \var{ModuleN}";;"
+were added at the top of each file.
+}%notop
+
+\notop{%
+\item["-output-obj"]
+Cause the linker to produce a C object file instead of
+\comp{a bytecode executable file}\nat{an executable file}.
+This is useful to wrap OCaml code as a C library,
+callable from any C program. See chapter~\ref{c:intf-c},
+section~\ref{s:embedded-code}. The name of the output object file
+must be set with the "-o" option.
+This option can also be used to produce a \comp{C source file (".c" extension) or
+a} compiled shared/dynamic library (".so" extension, ".dll" under Windows).
+}%notop
+
+\nat{%
+\item["-p"]
+Generate extra code to write profile information when the program is
+executed. The profile information can then be examined with the
+analysis program "gprof". (See chapter~\ref{c:profiler} for more
+information on profiling.) The "-p" option must be given both at
+compile-time and at link-time. Linking object files not compiled with
+"-p" is possible, but results in less precise profiling.
+
+\begin{unix} See the Unix manual page for "gprof(1)" for more
+information about the profiles.
+
+Full support for "gprof" is only available for certain platforms
+(currently: Intel x86 32 and 64 bits under Linux, BSD and MacOS X).
+On other platforms, the "-p" option will result in a less precise
+profile (no call graph information, only a time profile).
+\end{unix}
+
+\begin{windows}
+The "-p" option does not work under Windows.
+\end{windows}
+}%nat
+
+\nat{%
+\item["-pack"]
+Build an object file (".cmx" and ".o"/".obj" files) and its associated compiled
+interface (".cmi") that combines the ".cmx" object
+files given on the command line, making them appear as sub-modules of
+the output ".cmx" file. The name of the output ".cmx" file must be
+given with the "-o" option. For instance,
+\begin{verbatim}
+ ocamlopt -pack -o P.cmx A.cmx B.cmx C.cmx
+\end{verbatim}
+generates compiled files "P.cmx", "P.o" and "P.cmi" describing a
+compilation unit having three sub-modules "A", "B" and "C",
+corresponding to the contents of the object files "A.cmx", "B.cmx" and
+"C.cmx". These contents can be referenced as "P.A", "P.B" and "P.C"
+in the remainder of the program.
+
+The ".cmx" object files being combined must have been compiled with
+the appropriate "-for-pack" option. In the example above,
+"A.cmx", "B.cmx" and "C.cmx" must have been compiled with
+"ocamlopt -for-pack P".
+
+Multiple levels of packing can be achieved by combining "-pack" with
+"-for-pack". Consider the following example:
+\begin{verbatim}
+ ocamlopt -for-pack P.Q -c A.ml
+ ocamlopt -pack -o Q.cmx -for-pack P A.cmx
+ ocamlopt -for-pack P -c B.ml
+ ocamlopt -pack -o P.cmx Q.cmx B.cmx
+\end{verbatim}
+The resulting "P.cmx" object file has sub-modules "P.Q", "P.Q.A"
+and "P.B".
+}%nat
+
+\comp{%
+\item["-pack"]
+Build a bytecode object file (".cmo" file) and its associated compiled
+interface (".cmi") that combines the object
+files given on the command line, making them appear as sub-modules of
+the output ".cmo" file. The name of the output ".cmo" file must be
+given with the "-o" option. For instance,
+\begin{verbatim}
+ ocamlc -pack -o p.cmo a.cmo b.cmo c.cmo
+\end{verbatim}
+generates compiled files "p.cmo" and "p.cmi" describing a compilation
+unit having three sub-modules "A", "B" and "C", corresponding to the
+contents of the object files "a.cmo", "b.cmo" and "c.cmo". These
+contents can be referenced as "P.A", "P.B" and "P.C" in the remainder
+of the program.
+}%comp
+
+
+\notop{%
+\item["-plugin" \var{plugin}]
+Dynamically load the code of the given \var{plugin}
+(a ".cmo", ".cma" or ".cmxs" file) in the compiler. \var{plugin} must exist in
+the same kind of code as the compiler ({\machine \ocamlx.byte} must load bytecode
+plugins, while {\machine \ocamlx.opt} must load native code plugins), and
+extension adaptation is done automatically for ".cma" files (to ".cmxs" files
+if the compiler is compiled in native code).
+}%notop
+
+\notop{%
+\item["-pp" \var{command}]
+Cause the compiler to call the given \var{command} as a preprocessor
+for each source file. The output of \var{command} is redirected to
+an intermediate file, which is compiled. If there are no compilation
+errors, the intermediate file is deleted afterwards.
+}%notop
+
+\item["-ppx" \var{command}]
+After parsing, pipe the abstract syntax tree through the preprocessor
+\var{command}. The module "Ast_mapper", described in
+\ifouthtml
+chapter~\ref{c:parsinglib}: \ahref{libref/Ast\_mapper.html}{ \texttt{Ast_mapper} }
+\else section~\ref{Ast-underscoremapper}\fi,
+implements the external interface of a preprocessor.
+
+\item["-principal"]
+Check information path during type-checking, to make sure that all
+types are derived in a principal way. When using labelled arguments
+and/or polymorphic methods, this flag is required to ensure future
+versions of the compiler will be able to infer types correctly, even
+if internal algorithms change.
+All programs accepted in "-principal" mode are also accepted in the
+default mode with equivalent types, but different binary signatures,
+and this may slow down type checking; yet it is a good idea to
+use it once before publishing source code.
+
+\item["-rectypes"]
+Allow arbitrary recursive types during type-checking. By default,
+only recursive types where the recursion goes through an object type
+are supported.\notop{Note that once you have created an interface using this
+flag, you must use it again for all dependencies.}
+
+\notop{%
+\item["-runtime-variant" \var{suffix}]
+Add the \var{suffix} string to the name of the runtime library used by
+the program. Currently, only one such suffix is supported: "d", and
+only if the OCaml compiler was configured with option
+"-with-debug-runtime". This suffix gives the debug version of the
+runtime, which is useful for debugging pointer problems in low-level
+code such as C stubs.
+}%notop
+
+\nat{%
+\item["-S"]
+Keep the assembly code produced during the compilation. The assembly
+code for the source file \var{x}".ml" is saved in the file \var{x}".s".
+}%nat
+
+\nat{%
+\item["-shared"]
+Build a plugin (usually ".cmxs") that can be dynamically loaded with
+the "Dynlink" module. The name of the plugin must be
+set with the "-o" option. A plugin can include a number of OCaml
+modules and libraries, and extra native objects (".o", ".obj", ".a",
+".lib" files). Building native plugins is only supported for some
+operating system. Under some systems (currently,
+only Linux AMD 64), all the OCaml code linked in a plugin must have
+been compiled without the "-nodynlink" flag. Some constraints might also
+apply to the way the extra native objects have been compiled (under
+Linux AMD 64, they must contain only position-independent code).
+}%nat
+
+\item["-safe-string"]
+Enforce the separation between types "string" and "bytes",
+thereby making strings read-only. This is the default.
+
+\item["-short-paths"]
+When a type is visible under several module-paths, use the shortest
+one when printing the type's name in inferred interfaces and error and
+warning messages. Identifier names starting with an underscore "_" or
+containing double underscores "__" incur a penalty of $+10$ when computing
+their length.
+
+\top{
+\item["-stdin"]
+Read the standard input as a script file rather than starting an
+interactive session.
+}%top
+
+\item["-strict-sequence"]
+Force the left-hand part of each sequence to have type unit.
+
+\item["-strict-formats"]
+Reject invalid formats that were accepted in legacy format
+implementations. You should use this flag to detect and fix such
+invalid formats, as they will be rejected by future OCaml versions.
+
+\notop{%
+\item["-unboxed-types"]
+When a type is unboxable (i.e. a record with a single argument or a
+concrete datatype with a single constructor of one argument) it will
+be unboxed unless annotated with "[@@ocaml.boxed]".
+}%notop
+
+\notop{%
+\item["-no-unboxed-types"]
+When a type is unboxable it will be boxed unless annotated with
+"[@@ocaml.unboxed]". This is the default.
+}%notop
+
+\item["-unsafe"]
+Turn bound checking off for array and string accesses (the "v.(i)" and
+"s.[i]" constructs). Programs compiled with "-unsafe" are therefore
+\comp{slightly} faster, but unsafe: anything can happen if the program
+accesses an array or string outside of its bounds.
+\notop{%
+Additionally, turn off the check for zero divisor in integer division
+ and modulus operations. With "-unsafe", an integer division
+(or modulus) by zero can halt the program or continue with an
+unspecified result instead of raising a "Division_by_zero" exception.
+}%notop
+
+\item["-unsafe-string"]
+Identify the types "string" and "bytes", thereby making strings writable.
+This is intended for compatibility with old source code and should not
+be used with new software.
+
+\comp{%
+\item["-use-runtime" \var{runtime-name}]
+Generate a bytecode executable file that can be executed on the custom
+runtime system \var{runtime-name}, built earlier with
+"ocamlc -make-runtime" \var{runtime-name}.
+See section~\ref{s:custom-runtime} for more information.
+}%comp
+
+\item["-v"]
+Print the version number of the compiler and the location of the
+standard library directory, then exit.
+
+\item["-verbose"]
+Print all external commands before they are executed,
+\nat{in particular invocations of the assembler, C compiler, and linker.}
+\comp{in particular invocations of the C compiler and linker in "-custom" mode.}
+Useful to debug C library problems.
+
+\comp{%
+\item["-vmthread"]
+Compile or link multithreaded programs, in combination with the
+VM-level "threads" library described in chapter~\ref{c:threads}.
+}%comp
+
+\notop{%
+\item["-version" or "-vnum"]
+Print the version number of the compiler in short form (e.g. "3.11.0"),
+then exit.
+}%notop
+
+\top{%
+\item["-version"]
+Print version string and exit.
+
+\item["-vnum"]
+Print short version number and exit.
+
+\item["-no-version"]
+Do not print the version banner at startup.
+}%top
+
+\item["-w" \var{warning-list}]
+Enable, disable, or mark as fatal the warnings specified by the argument
+\var{warning-list}.
+Each warning can be {\em enabled} or {\em disabled}, and each warning
+can be {\em fatal} or {\em non-fatal}.
+If a warning is disabled, it isn't displayed and doesn't affect
+compilation in any way (even if it is fatal). If a warning is
+enabled, it is displayed normally by the compiler whenever the source
+code triggers it. If it is enabled and fatal, the compiler will also
+stop with an error after displaying it.
+
+The \var{warning-list} argument is a sequence of warning specifiers,
+with no separators between them. A warning specifier is one of the
+following:
+
+\begin{options}
+\item["+"\var{num}] Enable warning number \var{num}.
+\item["-"\var{num}] Disable warning number \var{num}.
+\item["@"\var{num}] Enable and mark as fatal warning number \var{num}.
+\item["+"\var{num1}..\var{num2}] Enable warnings in the given range.
+\item["-"\var{num1}..\var{num2}] Disable warnings in the given range.
+\item["@"\var{num1}..\var{num2}] Enable and mark as fatal warnings in
+the given range.
+\item["+"\var{letter}] Enable the set of warnings corresponding to
+\var{letter}. The letter may be uppercase or lowercase.
+\item["-"\var{letter}] Disable the set of warnings corresponding to
+\var{letter}. The letter may be uppercase or lowercase.
+\item["@"\var{letter}] Enable and mark as fatal the set of warnings
+corresponding to \var{letter}. The letter may be uppercase or
+lowercase.
+\item[\var{uppercase-letter}] Enable the set of warnings corresponding
+to \var{uppercase-letter}.
+\item[\var{lowercase-letter}] Disable the set of warnings corresponding
+to \var{lowercase-letter}.
+\end{options}
+
+Warning numbers and letters which are out of the range of warnings
+that are currently defined are ignored. The warnings are as follows.
+\begin{options}
+\input{warnings-help.tex}
+\end{options}
+
+The default setting is "-w +a-4-6-7-9-27-29-32..42-44-45-48-50-60".
+It is displayed by {\machine\ocamlx\ -help}.
+Note that warnings 5 and 10 are not always triggered, depending on
+the internals of the type checker.
+
+
+\item["-warn-error" \var{warning-list}]
+Mark as fatal the warnings specified in the argument \var{warning-list}.
+The compiler will stop with an error when one of these warnings is
+emitted. The \var{warning-list} has the same meaning as for
+the "-w" option: a "+" sign (or an uppercase letter) marks the
+corresponding warnings as fatal, a "-"
+sign (or a lowercase letter) turns them back into non-fatal warnings,
+and a "@" sign both enables and marks as fatal the corresponding
+warnings.
+
+Note: it is not recommended to use warning sets (i.e. letters) as
+arguments to "-warn-error"
+in production code, because this can break your build when future versions
+of OCaml add some new warnings.
+
+The default setting is "-warn-error -a+31" (only warning 31 is fatal).
+
+\item["-warn-help"]
+Show the description of all available warning numbers.
+
+\notop{%
+\item["-where"]
+Print the location of the standard library, then exit.
+}%notop
+
+\item["-" \var{file}]
+\notop{Process \var{file} as a file name, even if it starts with a dash ("-")
+character.}
+\top{Use \var{file} as a script file name, even when it starts with a
+hyphen (-).}
+
+\item["-help" or "--help"]
+Display a short usage summary and exit.
+
+\end{options}
+%
--- /dev/null
+\chapter*{Foreword}
+\markboth{Foreword}{}
+%HEVEA\cutname{foreword.html}
+
+This manual documents the release \ocamlversion\ of the OCaml
+system. It is organized as follows.
+\begin{itemize}
+\item Part~\ref{p:tutorials}, ``An introduction to OCaml'',
+gives an overview of the language.
+\item Part~\ref{p:refman}, ``The OCaml language'', is the
+reference description of the language.
+\item Part~\ref{p:commands}, ``The OCaml tools'', documents
+the compilers, toplevel system, and programming utilities.
+\item Part~\ref{p:library}, ``The OCaml library'', describes the
+modules provided in the standard library.
+\begin{latexonly}
+\item Part~\ref{p:appendix}, ``Appendix'', contains an
+index of all identifiers defined in the standard library, and an
+index of keywords.
+\end{latexonly}
+\end{itemize}
+
+\section*{Conventions}
+
+OCaml runs on several operating systems. The parts of
+this manual that are specific to one operating system are presented as
+shown below:
+
+\begin{unix} This is material specific to the Unix family of operating
+systems, including Linux and \hbox{MacOS~X}.
+\end{unix}
+
+\begin{windows} This is material specific to Microsoft Windows
+ (XP, Vista, 7, 8, 10).
+\end{windows}
+
+\section*{License}
+
+The OCaml system is copyright \copyright\ 1996--\number\year\
+Institut National de Recherche en Informatique et en
+Automatique (INRIA).
+INRIA holds all ownership rights to the OCaml system.
+
+The OCaml system is open source and can be freely
+redistributed. See the file "LICENSE" in the distribution for
+licensing information.
+
+The present documentation is copyright \copyright\ \number\year\
+Institut National de Recherche en Informatique et en
+Automatique (INRIA). The OCaml documentation and user's
+manual may be reproduced and distributed in whole or
+in part, subject to the following conditions:
+\begin{itemize}
+\item The copyright notice above and this permission notice must be
+preserved complete on all complete or partial copies.
+\item Any translation or derivative work of the OCaml
+documentation and user's manual must be approved by the authors in
+writing before distribution.
+\item If you distribute the OCaml
+documentation and user's manual in part, instructions for obtaining
+the complete version of this manual must be included, and a
+means for obtaining a complete version provided.
+\item Small portions may be reproduced as illustrations for reviews or
+quotes in other works without this permission notice if proper
+citation is given.
+\end{itemize}
+
+\section*{Availability}
+
+\begin{latexonly}
+The complete OCaml distribution can be accessed via the Web
+sites \url{http://www.ocaml.org/} and \url{http://caml.inria.fr/}.
+The former Web site contains a lot of additional information on OCaml.
+\end{latexonly}
+
+\begin{htmlonly}
+The complete OCaml distribution can be accessed via the
+\href{http://www.ocaml.org/}{community Caml Web site} and the
+\href{http://caml.inria.fr/}{older Caml Web site}.
+The \href{http://www.ocaml.org/}{community Caml Web site}
+contains a lot of additional information on OCaml.
+\end{htmlonly}
--- /dev/null
+*.html
+*.haux
+*.hind
+libref
+manual.hmanual
+manual.hmanual.kwd
+manual.css
+*.htoc
--- /dev/null
+<?xml version="1.0" standalone="no"?>
+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
+<svg xmlns="http://www.w3.org/2000/svg">
+<defs >
+<font id="FiraSans" horiz-adv-x="558" ><font-face
+ font-family="Fira Sans"
+ units-per-em="1000"
+ panose-1="2 11 5 3 5 0 0 2 0 4"
+ ascent="935"
+ descent="-265"
+ alphabetic="0" />
+<glyph unicode=" " glyph-name="space" horiz-adv-x="265" />
+<glyph unicode="!" glyph-name="exclam" horiz-adv-x="241" d="M170 689L160 230H79L68 689H170ZM150 127T170 107T190 58Q190 29 170 9T120 -12Q91 -12 71 8T51 58Q51 87 71 107T120 127Q150 127 170 107Z" />
+<glyph unicode=""" glyph-name="quotedbl" horiz-adv-x="399" d="M75 427L60 689H159L144 427H75ZM255 427L240 689H339L324 427H255Z" />
+<glyph unicode="#" glyph-name="numbersign" horiz-adv-x="518" d="M503 447H427L399 232H466V163H389L368 0H290L311 163H157L136 0H58L79 163H15V232H89L117 447H52V517H126L146 669H224L204 517H358L378 669H456L436 517H503V447ZM321 232L349 447H195L167 232H321Z" />
+<glyph unicode="$" glyph-name="dollar" horiz-adv-x="531" d="M491 110T443 58T310 -8V-155H230V-11Q107 -5 25 75L79 134Q151 64 251 64Q314 64 354 95T395 183Q395 216 383 238T339 277T250 312Q147 344 100 387T52 505Q52 575 101 622T230 678V824H310V677Q358
+672 396 654T470 602L417 544Q383 576 347 590T267 604Q214 604 181 580T147 509Q147 480 159 461T202 425T293 389Q356 370 398 347T465 285T491 186Q491 110 443 58Z" />
+<glyph unicode="%" glyph-name="percent" horiz-adv-x="826" d="M613 711L677 669L214 -31L150 11L613 711ZM279 679T324 633T370 510Q370 433 325 387T207 341Q136 341 91 387T45 510Q45 587 90 633T207 679Q279 679 324 633ZM163 617T145 587T126 510Q126 464
+144 434T207 403Q288 403 288 510Q288 556 270 586T207 617Q163 617 145 587ZM691 326T736 280T781 157Q781 80 736 34T619 -12Q547 -12 502 34T456 157Q456 234 501 280T619 326Q691 326 736 280ZM575 263T557 234T538 157Q538 111 556 81T619 50Q700 50 700 157Q700
+203 682 233T619 263Q575 263 557 234Z" />
+<glyph unicode="&" glyph-name="ampersand" horiz-adv-x="729" d="M356 701T397 682T462 627T485 549Q485 490 448 448T344 366L520 200Q560 281 580 369L666 344Q631 228 577 147L689 42L623 -12L526 82Q483 35 429 12T305 -12Q239 -12 189 11T110 76T81
+175Q81 237 116 283T220 374Q170 422 147 460T123 546Q123 614 170 657T302 701Q356 701 397 682ZM261 633T237 609T213 547Q213 511 232 483T292 415Q343 446 369 476T395 544Q395 586 370 609T303 633Q261 633 237 609ZM223 291T199 257T175 178Q175 123 213
+92T315 61Q362 61 400 79T473 133L273 324Q223 291 199 257Z" />
+<glyph unicode="'" glyph-name="quotesingle" horiz-adv-x="219" d="M75 427L60 689H159L144 427H75Z" />
+<glyph unicode="(" glyph-name="parenleft" horiz-adv-x="324" d="M284 805Q232 728 202 668T154 530T136 350Q136 248 153 171T201 33T284 -105L226 -145Q160 -51 125 9T65 154T40 350Q40 461 64 545T124 690T226 845L284 805Z" />
+<glyph unicode=")" glyph-name="parenright" horiz-adv-x="324" d="M164 751T199 691T259 546T284 350Q284 239 260 155T200 10T98 -145L40 -105Q92 -29 122 32T170 171T188 350Q188 453 171 530T123 667T40 805L98 845Q164 751 199 691Z" />
+<glyph unicode="*" glyph-name="asterisk" horiz-adv-x="439" d="M419 561L266 528L370 412L298 359L219 493L141 359L69 411L172 528L20 561L47 643L189 582L174 739H264L249 581L391 644L419 561Z" />
+<glyph unicode="+" glyph-name="plus" horiz-adv-x="499" d="M291 519V369H437V293H291V144H207V293H62V369H207V519H291Z" />
+<glyph unicode="," glyph-name="comma" horiz-adv-x="240" d="M149 127T169 107T189 58Q189 27 171 -13L104 -166H38L78 0Q65 10 58 25T50 58Q50 87 70 107T119 127Q149 127 169 107Z" />
+<glyph unicode="-" glyph-name="hyphen" horiz-adv-x="403" d="M60 274V352H343V274H60Z" />
+<glyph unicode="." glyph-name="period" horiz-adv-x="240" d="M149 127T169 107T189 58Q189 29 169 9T119 -12Q90 -12 70 8T50 58Q50 87 70 107T119 127Q149 127 169 107Z" />
+<glyph unicode="/" glyph-name="slash" horiz-adv-x="520" d="M337 807L415 789L184 -104L105 -85L337 807Z" />
+<glyph unicode="0" glyph-name="zero" d="M390 679T446 591T503 334Q503 166 447 77T279 -12Q168 -12 112 77T55 334Q55 502 111 590T279 679Q390 679 446 591ZM214 606T183 542T151 334Q151 190 182 126T279 61Q343 61 375 125T407 334Q407 477 375 541T279 606Q214
+606 183 542Z" />
+<glyph unicode="1" glyph-name="one" horiz-adv-x="433" d="M323 669V0H231V571L75 476L35 541L242 669H323Z" />
+<glyph unicode="2" glyph-name="two" horiz-adv-x="495" d="M288 679T333 655T404 590T429 496Q429 435 402 379T317 258T144 77H445L434 0H39V73Q173 212 229 276T309 389T333 492Q333 544 303 573T223 603Q182 603 151 586T85 530L25 578Q66 629 116 654T228
+679Q288 679 333 655Z" />
+<glyph unicode="3" glyph-name="three" horiz-adv-x="499" d="M287 679T331 656T399 594T423 509Q423 448 388 409T293 355Q360 349 402 307T444 193Q444 135 416 88T336 15T216 -12Q155 -12 104 10T15 78L70 129Q103 95 137 79T213 63Q276 63 312 98T348 194Q348
+260 314 287T215 314H165L176 385H210Q262 385 296 416T331 503Q331 550 301 577T220 605Q181 605 149 591T82 545L34 600Q119 679 225 679Q287 679 331 656Z" />
+<glyph unicode="4" glyph-name="four" horiz-adv-x="532" d="M502 238V165H415V0H326V165H40V231L241 679L318 647L137 238H327L335 418H415V238H502Z" />
+<glyph unicode="5" glyph-name="five" horiz-adv-x="501" d="M420 597H159V400Q210 426 266 426Q352 426 404 370T456 214Q456 148 427 97T346 17T224 -12Q163 -12 115 9T26 73L80 126Q112 94 146 79T223 63Q287 63 323 103T360 216Q360 289 327 322T238 355Q212
+355 190 350T143 332H71V669H433L420 597Z" />
+<glyph unicode="6" glyph-name="six" horiz-adv-x="533" d="M359 440T401 416T468 344T493 227Q493 156 465 102T388 18T280 -12Q163 -12 109 74T55 314Q55 423 85 505T173 633T308 679Q384 679 446 638L410 577Q363 606 307 606Q235 606 193 537T147 352Q209
+440 308 440Q359 440 401 416ZM338 61T369 105T400 224Q400 367 292 367Q248 367 211 343T148 275Q151 165 182 113T280 61Q338 61 369 105Z" />
+<glyph unicode="7" glyph-name="seven" horiz-adv-x="444" d="M414 669V600L164 -10L80 18L321 594H25V669H414Z" />
+<glyph unicode="8" glyph-name="eight" horiz-adv-x="551" d="M506 302T506 179Q506 124 477 81T394 13T274 -12Q206 -12 154 12T74 79T45 177Q45 239 78 281T177 351Q124 378 99 416T73 507Q73 561 101 600T176 659T276 679Q328 679 374 660T450 603T479 510Q479
+460 451 424T365 359Q506 302 506 179ZM224 610T194 583T163 506Q163 458 192 433T287 387L304 381Q349 407 369 436T389 507Q389 554 360 582T276 610Q224 610 194 583ZM337 61T373 93T410 178Q410 214 396 238T351 281T264 319L239 328Q189 304 165 268T141 177Q141
+122 177 92T275 61Q337 61 373 93Z" />
+<glyph unicode="9" glyph-name="nine" horiz-adv-x="525" d="M365 679T420 610T475 419Q475 282 438 199T325 66T119 -22L98 47Q232 85 303 150T380 323Q357 287 318 265T230 243Q178 243 136 269T70 344T45 458Q45 526 74 576T151 652T259 679Q365 679 420 610ZM328
+315T382 398Q384 509 355 557T261 606Q202 606 170 567T138 456Q138 386 168 351T249 315Q328 315 382 398Z" />
+<glyph unicode=":" glyph-name="colon" horiz-adv-x="240" d="M149 127T169 107T189 58Q189 29 169 9T119 -12Q90 -12 70 8T50 58Q50 87 70 107T119 127Q149 127 169 107ZM149 495T169 475T189 426Q189 397 169 377T119 356Q90 356 70 376T50 426Q50 455 70 475T119
+495Q149 495 169 475Z" />
+<glyph unicode=";" glyph-name="semicolon" horiz-adv-x="240" d="M149 127T169 107T189 58Q189 27 171 -13L104 -166H38L78 0Q65 10 58 25T50 58Q50 87 70 107T119 127Q149 127 169 107ZM149 495T169 475T189 426Q189 397 169 377T119 356Q90 356 70 376T50 426Q50
+455 70 475T119 495Q149 495 169 475Z" />
+<glyph unicode="<" glyph-name="less" horiz-adv-x="500" d="M417 551L450 475L123 333L450 189L417 115L50 286V380L417 551Z" />
+<glyph unicode="=" glyph-name="equal" horiz-adv-x="500" d="M62 389V466H438V389H62ZM62 452V529H438V452H62Z" />
+<glyph unicode=">" glyph-name="greater" horiz-adv-x="500" d="M83 551L450 380V286L83 115L50 189L377 333L50 475L83 551Z" />
+<glyph unicode="?" glyph-name="question" horiz-adv-x="459" d="M298 701T341 680T407 622T429 545Q429 506 416 479T383 434T332 394Q290 365 269 341T248 275V230H157V280Q157 323 171 353T206 401T259 442Q297 467 315 487T333 539Q333 580 306 602T232 625Q152
+625 93 553L30 602Q114 701 238 701Q298 701 341 680ZM235 127T255 107T275 58Q275 29 255 9T205 -12Q176 -12 156 8T136 58Q136 87 156 107T205 127Q235 127 255 107Z" />
+<glyph unicode="@" glyph-name="at" horiz-adv-x="1020" d="M660 701T756 648T901 504T950 307Q950 177 900 93T753 9Q697 9 666 40T625 112Q606 68 571 40T481 11Q401 11 355 71T308 231Q308 357 368 424T526 492Q568 492 605 483T683 452V193Q683 131 700 106T751
+80Q857 80 857 305Q857 402 819 474T707 585T526 625Q416 625 334 576T207 439T163 240Q163 129 205 44T330 -89T526 -137Q621 -137 718 -103L743 -174Q687 -194 638 -203T525 -213Q391 -213 288 -158T128 1T70 240Q70 370 127 475T289 640T526 701Q660 701 756
+648ZM567 78T600 164V411Q567 426 529 426Q398 426 398 231Q398 156 422 117T492 78Q567 78 600 164Z" />
+<glyph unicode="A" glyph-name="A" horiz-adv-x="573" d="M467 0L415 173H154L102 0H6L227 689H347L567 0H467ZM177 250H392L285 610L177 250Z" />
+<glyph unicode="B" glyph-name="B" horiz-adv-x="608" d="M475 352T519 314T563 196Q563 0 290 0H100V689H263Q394 689 463 646T533 515Q533 455 496 415T404 364Q475 352 519 314ZM195 614V397H299Q359 397 397 426T436 508Q436 568 396 591T273 614H195ZM374
+76T418 101T463 196Q463 264 420 294T308 324H195V76H290Q374 76 418 101Z" />
+<glyph unicode="C" glyph-name="C" horiz-adv-x="560" d="M403 701T445 685T532 633L480 572Q417 623 347 623Q261 623 209 557T156 345Q156 203 208 136T346 68Q390 68 423 83T493 125L540 65Q508 32 458 10T343 -12Q259 -12 194 29T92 151T55 345Q55 458 93
+538T196 660T341 701Q403 701 445 685Z" />
+<glyph unicode="D" glyph-name="D" horiz-adv-x="644" d="M400 689T494 617T589 348Q589 157 495 79T265 0H100V689H244Q400 689 494 617ZM195 613V75H272Q368 75 428 134T488 348Q488 457 457 515T378 593T265 613H195Z" />
+<glyph unicode="E" glyph-name="E" horiz-adv-x="535" d="M473 689L462 613H195V388H427V312H195V76H481V0H100V689H473Z" />
+<glyph unicode="F" glyph-name="F" horiz-adv-x="491" d="M100 0V689H466L455 613H195V378H420V303H195V0H100Z" />
+<glyph unicode="G" glyph-name="G" horiz-adv-x="631" d="M419 701T466 683T561 625L505 567Q468 597 434 610T354 623Q301 623 257 595T184 504T156 345Q156 200 203 133T344 66Q420 66 475 97V305H353L342 382H569V49Q462 -12 344 -12Q208 -12 132 79T55 345Q55
+457 95 537T204 659T354 701Q419 701 466 683Z" />
+<glyph unicode="H" glyph-name="H" horiz-adv-x="680" d="M485 0V323H195V0H100V689H195V401H485V689H580V0H485Z" />
+<glyph unicode="I" glyph-name="I" horiz-adv-x="295" d="M195 689V0H100V689H195Z" />
+<glyph unicode="J" glyph-name="J" horiz-adv-x="305" d="M210 96Q210 -6 166 -57T30 -137L5 -68Q51 -50 74 -29T106 22T115 100V689H210V96Z" />
+<glyph unicode="K" glyph-name="K" horiz-adv-x="589" d="M195 689V0H100V689H195ZM570 689L309 374L589 0H472L200 368L462 689H570Z" />
+<glyph unicode="L" glyph-name="L" horiz-adv-x="498" d="M195 689V83H478L467 0H100V689H195Z" />
+<glyph unicode="M" glyph-name="M" horiz-adv-x="778" d="M716 0H624L600 311Q585 494 583 592L434 78H345L188 593Q188 468 175 304L152 0H62L119 689H247L392 188L530 689H659L716 0Z" />
+<glyph unicode="N" glyph-name="N" horiz-adv-x="683" d="M583 0H456L176 585Q182 516 185 458T189 316V0H100V689H224L507 103Q504 129 499 194T494 313V689H583V0Z" />
+<glyph unicode="O" glyph-name="O" horiz-adv-x="692" d="M433 701T498 660T600 538T637 344Q637 232 601 152T499 30T346 -12Q259 -12 194 29T92 150T55 343Q55 454 91 535T194 658T346 701Q433 701 498 660ZM256 623T206 555T156 343Q156 200 206 133T346 66Q536
+66 536 344Q536 623 346 623Q256 623 206 555Z" />
+<glyph unicode="P" glyph-name="P" horiz-adv-x="581" d="M409 689T479 636T549 476Q549 363 476 308T282 253H195V0H100V689H281Q409 689 479 636ZM361 328T404 360T448 475Q448 549 405 582T280 615H195V328H278Q361 328 404 360Z" />
+<glyph unicode="Q" glyph-name="Q" horiz-adv-x="691" d="M534 39T579 23T666 -23L604 -103Q544 -50 490 -30T344 -10Q258 -10 193 30T92 150T55 343Q55 454 91 535T194 658T346 701Q433 701 498 660T600 538T637 344Q637 223 597 152T479 39Q534 39 579 23ZM156
+200T206 133T346 66Q536 66 536 344Q536 623 346 623Q256 623 206 555T156 343Q156 200 206 133Z" />
+<glyph unicode="R" glyph-name="R" horiz-adv-x="605" d="M302 292H195V0H100V689H281Q410 689 476 640T543 494Q543 422 506 377T394 309L580 0H467L302 292ZM291 365Q366 365 404 395T442 494Q442 558 404 586T280 615H195V365H291Z" />
+<glyph unicode="S" glyph-name="S" horiz-adv-x="545" d="M339 701T388 682T483 621L431 563Q392 594 355 608T274 623Q220 623 185 598T150 525Q150 495 162 475T206 437T301 401Q366 381 409 358T478 295T505 192Q505 132 476 86T391 14T259 -12Q116 -12 25
+77L77 135Q119 101 162 84T258 66Q322 66 364 97T406 189Q406 223 393 245T349 286T257 322Q151 354 102 399T53 521Q53 573 80 614T157 678T270 701Q339 701 388 682Z" />
+<glyph unicode="T" glyph-name="T" horiz-adv-x="517" d="M507 689L497 608H306V0H211V608H15V689H507Z" />
+<glyph unicode="U" glyph-name="U" horiz-adv-x="662" d="M572 221Q572 152 544 100T461 18T330 -12Q215 -12 153 51T90 221V689H185V228Q185 148 221 108T330 68Q404 68 440 107T476 228V689H572V221Z" />
+<glyph unicode="V" glyph-name="V" horiz-adv-x="556" d="M550 689L330 0H228L6 689H108L281 103L454 689H550Z" />
+<glyph unicode="W" glyph-name="W" horiz-adv-x="826" d="M801 689L661 0H539L412 577L284 0H165L25 689H118L229 83L362 689H463L599 83L714 689H801Z" />
+<glyph unicode="X" glyph-name="X" horiz-adv-x="540" d="M325 372L535 0H427L268 305L107 0H5L212 367L23 689H131L270 430L410 689H512L325 372Z" />
+<glyph unicode="Y" glyph-name="Y" horiz-adv-x="550" d="M545 689L323 265V0H227V264L5 689H110L278 348L446 689H545Z" />
+<glyph unicode="Z" glyph-name="Z" horiz-adv-x="522" d="M477 689V612L136 81H477L466 0H30V76L374 609H66V689H477Z" />
+<glyph unicode="[" glyph-name="bracketleft" horiz-adv-x="322" d="M272 816V739H152V-40H272V-116H65V816H272Z" />
+<glyph unicode="\" glyph-name="backslash" horiz-adv-x="520" d="M183 807L415 -85L336 -104L105 789L183 807Z" />
+<glyph unicode="]" glyph-name="bracketright" horiz-adv-x="322" d="M257 816V-116H50V-40H170V739H50V816H257Z" />
+<glyph unicode="^" glyph-name="asciicircum" horiz-adv-x="540" d="M311 840L500 527H402L269 760L137 527H40L229 840H311Z" />
+<glyph unicode="_" glyph-name="underscore" horiz-adv-x="520" d="M17 -142V-63H503V-142H17Z" />
+<glyph unicode="`" glyph-name="grave" horiz-adv-x="300" d="M71 801L270 687L242 638L30 724L71 801Z" />
+<glyph unicode="a" glyph-name="a" horiz-adv-x="544" d="M450 91T461 76T494 52L473 -12Q432 -7 407 11T370 67Q317 -12 213 -12Q135 -12 90 32T45 147Q45 231 105 276T277 321H358V360Q358 416 331 440T248 464Q190 464 106 436L83 503Q181 539 265 539Q358
+539 404 494T450 364V123Q450 91 461 76ZM313 57T358 139V260H289Q143 260 143 152Q143 105 166 81T234 57Q313 57 358 139Z" />
+<glyph unicode="b" glyph-name="b" horiz-adv-x="594" d="M426 539T479 467T532 264Q532 182 507 120T435 23T325 -12Q242 -12 185 58L176 0H95V739L187 750V461Q244 539 336 539Q426 539 479 467ZM364 61T398 110T433 264Q433 371 401 418T310 466Q240 466 187
+384V132Q208 99 238 80T303 61Q364 61 398 110Z" />
+<glyph unicode="c" glyph-name="c" horiz-adv-x="478" d="M334 539T373 526T448 482L404 424Q376 444 350 453T291 463Q227 463 192 412T156 261Q156 161 191 114T291 66Q322 66 348 75T406 106L448 46Q376 -12 287 -12Q180 -12 119 60T57 259Q57 343 85 406T164
+504T287 539Q334 539 373 526Z" />
+<glyph unicode="d" glyph-name="d" horiz-adv-x="598" d="M503 739V0H422L413 73Q387 33 348 11T261 -12Q167 -12 115 62T62 261Q62 342 87 405T159 503T269 539Q350 539 411 474V750L503 739ZM323 61T353 80T411 139V397Q385 431 356 448T289 466Q228 466 195
+415T161 263Q161 161 192 111T281 61Q323 61 353 80Z" />
+<glyph unicode="e" glyph-name="e" horiz-adv-x="545" d="M493 256T491 232H155Q161 145 199 104T297 63Q335 63 367 74T434 109L474 54Q390 -12 290 -12Q180 -12 119 60T57 258Q57 340 83 403T159 503T276 539Q381 539 437 470T493 279Q493 256 491 232ZM402
+306Q402 384 371 425T278 466Q165 466 155 300H402V306Z" />
+<glyph unicode="f" glyph-name="f" horiz-adv-x="335" d="M232 676T214 658T196 600V527H324L314 456H196V0H104V456H10V527H104V599Q104 667 147 708T269 750Q305 750 333 744T395 723L366 656Q321 676 274 676Q232 676 214 658Z" />
+<glyph unicode="g" glyph-name="g" horiz-adv-x="520" d="M520 503Q490 493 454 490T366 487Q459 445 459 354Q459 275 405 225T258 175Q222 175 191 185Q179 177 172 164T165 136Q165 93 234 93H318Q371 93 412 74T475 22T498 -53Q498 -130 435 -171T251 -213Q166
+-213 117 -196T46 -143T25 -53H108Q108 -85 120 -103T163 -131T251 -141Q334 -141 369 -121T405 -59Q405 -22 377 -3T299 16H216Q149 16 115 44T80 116Q80 142 95 166T138 209Q92 233 71 268T49 355Q49 408 75 450T148 515T252 539Q314 538 356 543T425 558T493
+586L520 503ZM200 473T172 441T143 355Q143 301 172 269T254 236Q308 236 336 267T365 356Q365 473 252 473Q200 473 172 441Z" />
+<glyph unicode="h" glyph-name="h" horiz-adv-x="586" d="M415 539T455 496T496 378V0H404V365Q404 421 383 444T320 467Q279 467 247 443T187 375V0H95V738L187 748V454Q249 539 343 539Q415 539 455 496Z" />
+<glyph unicode="i" glyph-name="i" horiz-adv-x="282" d="M187 527V0H95V527H187ZM169 780T187 762T205 717Q205 690 187 673T140 655Q112 655 94 672T76 717Q76 744 94 762T140 780Q169 780 187 762Z" />
+<glyph unicode="j" glyph-name="j" horiz-adv-x="280" d="M185 32Q185 -41 167 -85T115 -156T18 -212L-9 -145Q30 -127 51 -110T82 -61T93 26V527H185V32ZM168 780T186 762T204 717Q204 690 186 673T139 655Q111 655 93 672T75 717Q75 744 93 762T139 780Q168
+780 186 762Z" />
+<glyph unicode="k" glyph-name="k" horiz-adv-x="512" d="M187 750V0H95V739L187 750ZM490 527L296 294L512 0H402L193 288L387 527H490Z" />
+<glyph unicode="l" glyph-name="l" horiz-adv-x="293" d="M149 -12T120 18T90 104V739L182 750V106Q182 84 189 74T215 64Q234 64 249 70L273 6Q240 -12 200 -12Q149 -12 120 18Z" />
+<glyph unicode="m" glyph-name="m" horiz-adv-x="857" d="M689 539T728 496T767 378V0H675V365Q675 467 601 467Q562 467 535 445T477 374V0H385V365Q385 467 311 467Q271 467 244 444T187 374V0H95V527H174L182 450Q241 539 334 539Q383 539 417 514T467 444Q498
+490 535 514T624 539Q689 539 728 496Z" />
+<glyph unicode="n" glyph-name="n" horiz-adv-x="586" d="M415 539T455 496T496 378V0H404V365Q404 421 383 444T321 467Q279 467 247 443T187 374V0H95V527H174L182 449Q210 491 251 515T343 539Q415 539 455 496Z" />
+<glyph unicode="o" glyph-name="o" horiz-adv-x="584" d="M404 539T465 465T527 264Q527 182 499 120T418 23T292 -12Q181 -12 119 62T57 263Q57 345 85 407T166 504T293 539Q404 539 465 465ZM156 465T156 263Q156 62 292 62Q428 62 428 264Q428 465 293 465Q156
+465 156 263Z" />
+<glyph unicode="p" glyph-name="p" horiz-adv-x="594" d="M438 539T485 467T532 264Q532 140 478 64T325 -12Q237 -12 187 48V-202L95 -213V527H174L181 456Q210 496 251 517T337 539Q438 539 485 467ZM433 63T433 264Q433 466 314 466Q275 466 243 443T187 384V127Q207
+96 237 80T303 63Q433 63 433 264Z" />
+<glyph unicode="q" glyph-name="q" horiz-adv-x="598" d="M503 527V-213L411 -202V70Q385 31 347 10T261 -12Q167 -12 115 62T62 261Q62 342 87 405T159 503T269 539Q353 539 417 468L424 527H503ZM323 61T353 80T411 139V397Q385 431 356 448T289 466Q228 466
+195 415T161 263Q161 161 192 111T281 61Q323 61 353 80Z" />
+<glyph unicode="r" glyph-name="r" horiz-adv-x="386" d="M352 539T376 533L359 443Q335 449 313 449Q264 449 234 413T187 301V0H95V527H174L183 420Q204 479 240 509T324 539Q352 539 376 533Z" />
+<glyph unicode="s" glyph-name="s" horiz-adv-x="467" d="M292 539T335 524T417 479L378 421Q342 444 310 455T241 466Q196 466 170 448T144 397Q144 365 168 347T257 312Q345 290 388 252T432 148Q432 70 372 29T224 -12Q104 -12 25 57L74 113Q141 62 222 62Q274
+62 304 83T335 142Q335 169 324 185T286 214T207 241Q123 263 86 300T48 394Q48 435 72 468T140 520T238 539Q292 539 335 524Z" />
+<glyph unicode="t" glyph-name="t" horiz-adv-x="361" d="M361 24Q309 -12 243 -12Q176 -12 139 26T101 138V456H9V527H101V646L193 657V527H318L308 456H193V142Q193 101 207 83T256 64Q287 64 326 85L361 24Z" />
+<glyph unicode="u" glyph-name="u" horiz-adv-x="582" d="M487 0H408L401 82Q371 33 332 11T237 -12Q168 -12 129 30T90 149V527H182V159Q182 105 201 83T263 60Q340 60 395 151V527H487V0Z" />
+<glyph unicode="v" glyph-name="v" horiz-adv-x="492" d="M482 527L303 0H192L10 527H110L248 82L385 527H482Z" />
+<glyph unicode="w" glyph-name="w" horiz-adv-x="717" d="M697 527L577 0H452L360 444L265 0H143L20 527H112L207 64L311 527H414L513 64L609 527H697Z" />
+<glyph unicode="x" glyph-name="x" horiz-adv-x="485" d="M297 282L480 0H369L240 223L109 0H5L189 278L26 527H134L244 334L355 527H459L297 282Z" />
+<glyph unicode="y" glyph-name="y" horiz-adv-x="492" d="M306 -3Q275 -95 220 -148T61 -213L51 -141Q103 -132 134 -115T183 -72T218 0H187L10 527H108L249 67L387 527H482L306 -3Z" />
+<glyph unicode="z" glyph-name="z" horiz-adv-x="437" d="M404 527V457L129 77H407L396 0H25V69L299 449H48V527H404Z" />
+<glyph unicode="{" glyph-name="braceleft" horiz-adv-x="322" d="M277 765Q226 765 204 750T182 697V458Q182 407 164 385T107 349Q147 335 164 314T182 242V3Q182 -34 204 -49T277 -65V-136Q177 -136 136 -102T95 13V235Q95 277 80 294T25 311V387Q64 387 79
+405T95 465V687Q95 767 136 801T277 836V765Z" />
+<glyph unicode="|" glyph-name="bar" horiz-adv-x="403" d="M243 807V-102H160V807H243Z" />
+<glyph unicode="}" glyph-name="braceright" horiz-adv-x="322" d="M145 836T186 802T227 687V465Q227 423 242 405T297 387V311Q258 311 243 294T227 235V13Q227 -67 186 -101T45 -136V-65Q96 -65 118 -50T140 3V242Q140 293 157 314T215 349Q176 362 158 384T140
+458V697Q140 734 118 749T45 765V836Q145 836 186 802Z" />
+<glyph unicode="~" glyph-name="asciitilde" horiz-adv-x="488" d="M290 250T269 259T217 288Q199 300 187 306T163 312Q124 312 91 258L35 287Q85 384 172 384Q200 384 221 375T270 348Q290 335 302 329T328 323Q349 323 367 336T398 371L453 341Q406 250 319
+250Q290 250 269 259Z" />
+<glyph unicode=" " glyph-name="uni00A0" horiz-adv-x="265" />
+<glyph unicode="¡" glyph-name="exclamdown" horiz-adv-x="241" d="M150 495T170 475T190 425Q190 396 170 376T121 356Q91 356 71 376T51 425Q51 454 71 474T121 495Q150 495 170 475ZM162 247L173 -202H71L81 247H162Z" />
+<glyph unicode="¢" glyph-name="cent" horiz-adv-x="478" d="M448 46Q392 1 329 -9V-154H249V-9Q159 3 108 73T57 259Q57 374 108 448T250 536V684H329V536Q394 527 448 482L404 424Q376 444 350 453T291 463Q227 463 192 412T156 261Q156 161 191 114T291
+66Q322 66 348 75T406 106L448 46Z" />
+<glyph unicode="£" glyph-name="sterling" horiz-adv-x="520" d="M213 153T200 125T152 77H472L461 0H40V73Q75 86 92 100T115 138T122 205V322H56V382H122V493Q122 576 172 627T311 679Q366 679 410 659T490 596L430 550Q406 578 379 591T315 604Q266 604
+240 576T213 494V382H421V322H213V204Q213 153 200 125Z" />
+<glyph unicode="¤" glyph-name="currency" horiz-adv-x="560" d="M492 272T455 218L531 143L476 88L398 164Q345 132 278 132Q212 132 160 167L82 88L29 143L107 221Q71 274 71 341Q71 406 106 460L29 540L84 595L162 515Q211 549 278 549Q347 549 399 516L478
+595L531 540L455 463Q492 411 492 341Q492 272 455 218ZM341 205T372 241T404 342Q404 407 373 443T281 479Q222 479 191 443T159 342Q159 277 190 241T281 205Q341 205 372 241Z" />
+<glyph unicode="¥" glyph-name="yen" horiz-adv-x="536" d="M531 669L340 346H453V284H315V194H453V133H315V0H221V133H82V194H221V284H82V346H196L5 669H107L271 374L434 669H531Z" />
+<glyph unicode="¦" glyph-name="brokenbar" horiz-adv-x="403" d="M243 807V443H160V807H243ZM243 262V-102H160V262H243Z" />
+<glyph unicode="§" glyph-name="section" horiz-adv-x="533" d="M441 136T441 75Q441 8 387 -31T246 -71Q149 -71 78 -21L113 40Q143 20 175 11T249 1Q293 1 321 18T349 66Q349 90 339 105T304 133T225 163Q142 190 106 222T70 311Q70 347 90 378T147 432Q120
+450 107 474T94 533Q94 600 146 638T281 677Q378 677 452 623L417 565Q384 586 352 596T280 606Q235 606 210 589T185 540Q185 516 194 501T230 471T307 440Q390 412 426 379T463 293Q463 224 387 173Q441 136 441 75ZM159 287T178 269T254 233Q297 219 333 203Q353
+221 364 241T375 280Q375 304 366 319T335 347T267 376Q232 389 200 403Q181 384 170 363T159 323Q159 287 178 269Z" />
+<glyph unicode="¨" glyph-name="dieresis" horiz-adv-x="385" d="M112 768T128 752T145 711Q145 687 129 671T88 654Q63 654 47 670T30 711Q30 735 46 751T88 768Q112 768 128 752ZM322 768T338 752T355 711Q355 687 339 671T297 654Q273 654 257 670T240
+711Q240 735 256 751T297 768Q322 768 338 752Z" />
+<glyph unicode="©" glyph-name="copyright" horiz-adv-x="810" d="M492 748T563 708T676 596T718 434Q718 344 677 273T564 161T406 121Q320 121 248 161T134 272T92 434Q92 524 134 595T248 707T406 748Q492 748 563 708ZM334 696T277 663T186 570T153 434Q153
+358 186 299T276 207T406 174Q477 174 534 207T625 299T658 434Q658 510 625 570T535 663T406 696Q334 696 277 663ZM444 625T471 615T525 585L490 538Q452 565 412 565Q371 565 346 533T321 435Q321 372 345 340T412 308Q437 308 456 315T496 339L528 291Q476
+245 409 245Q335 245 290 295T245 435Q245 495 267 538T326 603T408 625Q444 625 471 615Z" />
+<glyph unicode="ª" glyph-name="ordfeminine" horiz-adv-x="500" d="M313 525V549Q313 588 293 604T230 620Q181 620 117 599L95 661Q173 689 245 689Q402 689 402 554V384Q402 361 410 350T435 333L416 272Q381 276 360 289T327 331Q306 301 274 286T201
+271Q138 271 102 304T65 393Q65 457 114 491T255 525H313ZM280 337T313 390V470H265Q159 470 159 398Q159 369 176 353T224 337Q280 337 313 390ZM71 77H447V0H71V77Z" />
+<glyph unicode="«" glyph-name="guillemotleft" horiz-adv-x="575" d="M230 535L285 497L150 287L285 77L230 39L55 255V318L230 535ZM465 535L520 497L385 287L520 77L465 39L290 255V318L465 535Z" />
+<glyph unicode="¬" glyph-name="logicalnot" horiz-adv-x="500" d="M438 361V141H355V284H62V361H438Z" />
+<glyph unicode="­" glyph-name="uni00AD" horiz-adv-x="403" d="M60 274V352H343V274H60Z" />
+<glyph unicode="®" glyph-name="registered" horiz-adv-x="641" d="M390 750T448 716T540 622T574 493Q574 423 541 365T449 272T319 238Q250 238 192 272T101 364T67 493Q67 563 100 622T192 715T319 750Q390 750 448 716ZM377 287T422 313T493 387T519
+493Q519 552 494 599T423 674T319 701Q263 701 218 674T148 600T122 493Q122 434 147 387T218 314T319 287Q377 287 422 313ZM428 522T410 503T363 474L437 359H370L309 465H285V359H228V635H306Q428 635 428 551Q428 522 410 503ZM285 509H315Q369 509 369 551Q369
+572 356 581T313 591H285V509Z" />
+<glyph unicode="¯" glyph-name="overscore" horiz-adv-x="333" d="M303 667H30V736H303V667Z" />
+<glyph unicode="°" glyph-name="degree" horiz-adv-x="523" d="M176 381T139 400T78 455T55 541Q55 590 78 626T138 682T219 701Q262 701 299 682T360 626T383 540Q383 491 360 455T300 400T219 381Q176 381 139 400ZM256 443T281 468T306 540Q306 587 281
+612T219 638Q182 638 157 613T132 541Q132 494 157 469T219 443Q256 443 281 468Z" />
+<glyph unicode="±" glyph-name="plusminus" horiz-adv-x="500" d="M62 0V77H438V0H62ZM292 542V392H438V316H292V167H208V316H63V392H208V542H292Z" />
+<glyph unicode="²" glyph-name="uni00B2" horiz-adv-x="400" d="M259 746T296 712T334 626Q334 592 318 561T264 489T155 384H344L336 322H67V380Q151 461 187 499T238 565T254 620Q254 650 236 667T189 684Q163 684 144 674T104 640L55 678Q110 746 195
+746Q259 746 296 712Z" />
+<glyph unicode="³" glyph-name="uni00B3" horiz-adv-x="400" d="M261 746T297 716T334 641Q334 603 311 578T248 543Q292 539 320 513T348 441Q348 386 306 350T191 313Q104 313 52 373L97 415Q135 374 187 374Q224 374 245 393T267 445Q267 481 247 496T187
+512H153L162 568H185Q217 568 237 584T257 631Q257 657 239 672T191 687Q166 687 145 678T103 650L63 694Q121 746 197 746Q261 746 297 716Z" />
+<glyph unicode="´" glyph-name="acute" horiz-adv-x="300" d="M229 801L270 724L58 638L30 687L229 801Z" />
+<glyph unicode="µ" glyph-name="uni00B5" horiz-adv-x="588" d="M487 80T513 0L427 -12Q416 14 412 33T403 85V86Q379 44 344 16T265 -12Q230 -12 208 -1T169 38Q178 10 182 -20T186 -96V-202L95 -213V527H187V156Q187 67 266 67Q346 67 395 163V527H487V180Q487
+80 513 0Z" />
+<glyph unicode="¶" glyph-name="paragraph" horiz-adv-x="734" d="M594 689V-202L511 -215V616H397V-202L314 -215V282Q201 288 146 343T90 486Q90 583 156 636T336 689H594Z" />
+<glyph unicode="·" glyph-name="middot" horiz-adv-x="240" d="M149 380T169 360T189 311Q189 282 169 262T119 241Q90 241 70 261T50 311Q50 340 70 360T119 380Q149 380 169 360Z" />
+<glyph unicode="¸" glyph-name="cedilla" horiz-adv-x="275" d="M152 -56Q200 -60 222 -83T245 -141Q245 -189 210 -215T121 -241Q93 -241 69 -235T30 -217L55 -165Q85 -181 118 -181Q141 -181 154 -172T168 -141Q168 -120 147 -110T79 -99L93 16H152V-56Z" />
+<glyph unicode="¹" glyph-name="uni00B9" horiz-adv-x="400" d="M274 739V322H197V660L99 603L65 656L205 739H274Z" />
+<glyph unicode="º" glyph-name="ordmasculine" horiz-adv-x="500" d="M343 689T393 634T444 480Q444 385 393 328T250 271Q158 271 107 327T56 480Q56 575 108 632T251 689Q343 689 393 634ZM151 620T151 480Q151 340 250 340Q349 340 349 480Q349 552 325
+586T251 620Q151 620 151 480ZM62 0V77H438V0H62Z" />
+<glyph unicode="»" glyph-name="guillemotright" horiz-adv-x="566" d="M110 535L285 318V255L110 39L55 77L190 287L55 497L110 535ZM336 535L511 318V255L336 39L281 77L416 287L281 497L336 535Z" />
+<glyph unicode="¼" glyph-name="onequarter" horiz-adv-x="932" d="M274 689V272H197V610L99 553L65 606L205 689H274ZM640 750L699 721L293 -78L233 -49L640 750ZM889 156V96H836V0H760V96H574V150L702 424L768 399L655 156H761L768 261H836V156H889Z" />
+<glyph unicode="½" glyph-name="onehalf" horiz-adv-x="932" d="M274 689V272H197V610L99 553L65 606L205 689H274ZM640 750L699 721L293 -78L233 -49L640 750ZM791 424T828 390T866 304Q866 270 850 239T796 167T687 62H876L868 0H599V58Q683 139 719 177T770
+243T786 298Q786 328 768 345T721 362Q695 362 676 352T636 318L587 356Q642 424 727 424Q791 424 828 390Z" />
+<glyph unicode="¾" glyph-name="threequarters" horiz-adv-x="932" d="M261 696T297 666T334 591Q334 553 311 528T248 493Q292 489 320 463T348 391Q348 336 306 300T191 263Q104 263 52 323L97 365Q135 324 187 324Q224 324 245 343T267 395Q267 431 247
+446T187 462H153L162 518H185Q217 518 237 534T257 581Q257 607 239 622T191 637Q166 637 145 628T103 600L63 644Q121 696 197 696Q261 696 297 666ZM640 750L699 721L293 -78L233 -49L640 750ZM889 156V96H836V0H760V96H574V150L702 424L768 399L655 156H761L768
+261H836V156H889Z" />
+<glyph unicode="¿" glyph-name="questiondown" horiz-adv-x="459" d="M224 356T204 376T184 425Q184 454 204 474T254 495Q283 495 303 475T323 425Q323 396 303 376T254 356Q224 356 204 376ZM161 -215T118 -194T52 -136T30 -59Q30 -19 43 8T77 53T129 92Q170
+120 190 143T211 206V247H302V201Q302 159 288 130T254 84T201 44Q163 20 145 0T126 -53Q126 -94 153 -116T227 -139Q307 -139 366 -67L429 -116Q345 -215 221 -215Q161 -215 118 -194Z" />
+<glyph unicode="À" glyph-name="Agrave" horiz-adv-x="573" d="M467 0L415 173H154L102 0H6L227 689H347L567 0H467ZM177 250H392L285 610L177 250ZM196 911L397 804L373 755L157 834L196 911Z" />
+<glyph unicode="Á" glyph-name="Aacute" horiz-adv-x="573" d="M467 0L415 173H154L102 0H6L227 689H347L567 0H467ZM177 250H392L285 610L177 250ZM367 911L407 834L191 755L167 804L367 911Z" />
+<glyph unicode="Â" glyph-name="Acircumflex" horiz-adv-x="573" d="M467 0L415 173H154L102 0H6L227 689H347L567 0H467ZM177 250H392L285 610L177 250ZM160 759L120 804L256 914H317L452 804L413 759L286 840L160 759Z" />
+<glyph unicode="Ã" glyph-name="Atilde" horiz-adv-x="573" d="M467 0L415 173H154L102 0H6L227 689H347L567 0H467ZM177 250H392L285 610L177 250ZM326 782T311 789T276 809Q261 820 251 825T229 830Q213 830 201 819T176 784L120 812Q139 852 166 876T229
+900Q250 900 265 893T299 872Q302 870 311 864T329 855T345 852Q360 852 372 862T398 896L454 868Q435 826 407 804T345 782Q326 782 311 789Z" />
+<glyph unicode="Ä" glyph-name="Adieresis" horiz-adv-x="573" d="M467 0L415 173H154L102 0H6L227 689H347L567 0H467ZM177 250H392L285 610L177 250ZM206 894T222 878T239 837Q239 813 223 797T182 780Q157 780 141 796T124 837Q124 861 140 877T182 894Q206
+894 222 878ZM416 894T432 878T449 837Q449 813 433 797T391 780Q367 780 351 796T334 837Q334 861 350 877T391 894Q416 894 432 878Z" />
+<glyph unicode="Å" glyph-name="Aring" horiz-adv-x="573" d="M467 0L415 173H154L102 0H6L227 689H347L567 0H467ZM177 250H392L285 610L177 250ZM337 962T369 932T401 856Q401 811 369 781T287 750Q237 750 205 780T173 856Q173 901 205 931T287 962Q337
+962 369 932ZM262 912T248 897T234 856Q234 830 248 815T287 800Q311 800 325 815T340 856Q340 882 326 897T287 912Q262 912 248 897Z" />
+<glyph unicode="Æ" glyph-name="AE" horiz-adv-x="816" d="M535 76H762V0H458L418 173H150L85 0H-12L262 689H721L710 613H401L457 387H712V311H476L535 76ZM179 250H400L316 613L179 250Z" />
+<glyph unicode="Ç" glyph-name="Ccedilla" horiz-adv-x="560" d="M512 36T471 16T376 -10V-56Q424 -60 446 -83T469 -141Q469 -189 434 -215T345 -241Q317 -241 293 -235T254 -217L279 -165Q309 -181 342 -181Q365 -181 378 -172T392 -141Q392 -120 371 -110T303
+-99L314 -11Q237 -4 179 39T88 160T55 345Q55 458 93 538T196 660T341 701Q403 701 445 685T532 633L480 572Q417 623 347 623Q261 623 209 557T156 345Q156 203 208 136T346 68Q390 68 423 83T493 125L540 65Q512 36 471 16Z" />
+<glyph unicode="È" glyph-name="Egrave" horiz-adv-x="535" d="M473 689L462 613H195V388H427V312H195V76H481V0H100V689H473ZM199 911L400 804L376 755L160 834L199 911Z" />
+<glyph unicode="É" glyph-name="Eacute" horiz-adv-x="535" d="M473 689L462 613H195V388H427V312H195V76H481V0H100V689H473ZM370 911L410 834L194 755L170 804L370 911Z" />
+<glyph unicode="Ê" glyph-name="Ecircumflex" horiz-adv-x="535" d="M473 689L462 613H195V388H427V312H195V76H481V0H100V689H473ZM163 759L123 804L259 914H320L455 804L416 759L289 840L163 759Z" />
+<glyph unicode="Ë" glyph-name="Edieresis" horiz-adv-x="535" d="M473 689L462 613H195V388H427V312H195V76H481V0H100V689H473ZM209 894T225 878T242 837Q242 813 226 797T185 780Q160 780 144 796T127 837Q127 861 143 877T185 894Q209 894 225 878ZM419
+894T435 878T452 837Q452 813 436 797T394 780Q370 780 354 796T337 837Q337 861 353 877T394 894Q419 894 435 878Z" />
+<glyph unicode="Ì" glyph-name="Igrave" horiz-adv-x="295" d="M195 689V0H100V689H195ZM56 911L257 804L233 755L17 834L56 911Z" />
+<glyph unicode="Í" glyph-name="Iacute" horiz-adv-x="295" d="M195 689V0H100V689H195ZM227 911L267 834L51 755L27 804L227 911Z" />
+<glyph unicode="Î" glyph-name="Icircumflex" horiz-adv-x="295" d="M195 689V0H100V689H195ZM20 759L-20 804L116 914H177L312 804L273 759L146 840L20 759Z" />
+<glyph unicode="Ï" glyph-name="Idieresis" horiz-adv-x="295" d="M195 689V0H100V689H195ZM66 894T82 878T99 837Q99 813 83 797T42 780Q17 780 1 796T-16 837Q-16 861 0 877T42 894Q66 894 82 878ZM276 894T292 878T309 837Q309 813 293 797T251 780Q227
+780 211 796T194 837Q194 861 210 877T251 894Q276 894 292 878Z" />
+<glyph unicode="Ð" glyph-name="Eth" horiz-adv-x="656" d="M412 689T506 617T601 348Q601 157 507 79T277 0H112V318H20V388H112V689H256Q412 689 506 617ZM380 75T440 134T500 348Q500 457 469 515T390 593T277 613H207V388H364V318H207V75H284Q380 75 440 134Z" />
+<glyph unicode="Ñ" glyph-name="Ntilde" horiz-adv-x="683" d="M583 0H456L176 585Q182 516 185 458T189 316V0H100V689H224L507 103Q504 129 499 194T494 313V689H583V0ZM392 782T377 789T342 809Q327 820 317 825T295 830Q279 830 267 819T242 784L186
+812Q205 852 232 876T295 900Q316 900 331 893T365 872Q368 870 377 864T395 855T411 852Q426 852 438 862T464 896L520 868Q501 826 473 804T411 782Q392 782 377 789Z" />
+<glyph unicode="Ò" glyph-name="Ograve" horiz-adv-x="692" d="M433 701T498 660T600 538T637 344Q637 232 601 152T499 30T346 -12Q259 -12 194 29T92 150T55 343Q55 454 91 535T194 658T346 701Q433 701 498 660ZM256 623T206 555T156 343Q156 200 206
+133T346 66Q536 66 536 344Q536 623 346 623Q256 623 206 555ZM255 911L456 804L432 755L216 834L255 911Z" />
+<glyph unicode="Ó" glyph-name="Oacute" horiz-adv-x="692" d="M433 701T498 660T600 538T637 344Q637 232 601 152T499 30T346 -12Q259 -12 194 29T92 150T55 343Q55 454 91 535T194 658T346 701Q433 701 498 660ZM256 623T206 555T156 343Q156 200 206
+133T346 66Q536 66 536 344Q536 623 346 623Q256 623 206 555ZM426 911L466 834L250 755L226 804L426 911Z" />
+<glyph unicode="Ô" glyph-name="Ocircumflex" horiz-adv-x="692" d="M433 701T498 660T600 538T637 344Q637 232 601 152T499 30T346 -12Q259 -12 194 29T92 150T55 343Q55 454 91 535T194 658T346 701Q433 701 498 660ZM256 623T206 555T156 343Q156 200
+206 133T346 66Q536 66 536 344Q536 623 346 623Q256 623 206 555ZM219 759L179 804L315 914H376L511 804L472 759L345 840L219 759Z" />
+<glyph unicode="Õ" glyph-name="Otilde" horiz-adv-x="692" d="M433 701T498 660T600 538T637 344Q637 232 601 152T499 30T346 -12Q259 -12 194 29T92 150T55 343Q55 454 91 535T194 658T346 701Q433 701 498 660ZM256 623T206 555T156 343Q156 200 206
+133T346 66Q536 66 536 344Q536 623 346 623Q256 623 206 555ZM385 782T370 789T335 809Q320 820 310 825T288 830Q272 830 260 819T235 784L179 812Q198 852 225 876T288 900Q309 900 324 893T358 872Q361 870 370 864T388 855T404 852Q419 852 431 862T457 896L513
+868Q494 826 466 804T404 782Q385 782 370 789Z" />
+<glyph unicode="Ö" glyph-name="Odieresis" horiz-adv-x="692" d="M433 701T498 660T600 538T637 344Q637 232 601 152T499 30T346 -12Q259 -12 194 29T92 150T55 343Q55 454 91 535T194 658T346 701Q433 701 498 660ZM256 623T206 555T156 343Q156 200 206
+133T346 66Q536 66 536 344Q536 623 346 623Q256 623 206 555ZM265 894T281 878T298 837Q298 813 282 797T241 780Q216 780 200 796T183 837Q183 861 199 877T241 894Q265 894 281 878ZM475 894T491 878T508 837Q508 813 492 797T450 780Q426 780 410 796T393 837Q393
+861 409 877T450 894Q475 894 491 878Z" />
+<glyph unicode="×" glyph-name="multiply" horiz-adv-x="500" d="M372 486L428 429L308 309L428 185L372 129L252 253L128 129L72 185L192 305L72 429L128 486L248 361L372 486Z" />
+<glyph unicode="Ø" glyph-name="Oslash" horiz-adv-x="692" d="M558 628T597 546T637 344Q637 232 601 152T499 30T346 -12Q310 -12 279 -5L244 -127L165 -106L205 22Q134 62 95 143T55 343Q55 454 91 535T194 658T346 701Q383 701 412 694L449 819L528 798L486
+667Q558 628 597 546ZM256 623T206 555T156 343Q156 158 238 97L396 618Q369 623 346 623Q256 623 206 555ZM536 66T536 344Q536 443 515 504T452 594L296 71Q321 66 346 66Q536 66 536 344Z" />
+<glyph unicode="Ù" glyph-name="Ugrave" horiz-adv-x="662" d="M572 221Q572 152 544 100T461 18T330 -12Q215 -12 153 51T90 221V689H185V228Q185 148 221 108T330 68Q404 68 440 107T476 228V689H572V221ZM240 911L441 804L417 755L201 834L240 911Z" />
+<glyph unicode="Ú" glyph-name="Uacute" horiz-adv-x="662" d="M572 221Q572 152 544 100T461 18T330 -12Q215 -12 153 51T90 221V689H185V228Q185 148 221 108T330 68Q404 68 440 107T476 228V689H572V221ZM411 911L451 834L235 755L211 804L411 911Z" />
+<glyph unicode="Û" glyph-name="Ucircumflex" horiz-adv-x="662" d="M572 221Q572 152 544 100T461 18T330 -12Q215 -12 153 51T90 221V689H185V228Q185 148 221 108T330 68Q404 68 440 107T476 228V689H572V221ZM204 759L164 804L300 914H361L496 804L457
+759L330 840L204 759Z" />
+<glyph unicode="Ü" glyph-name="Udieresis" horiz-adv-x="662" d="M572 221Q572 152 544 100T461 18T330 -12Q215 -12 153 51T90 221V689H185V228Q185 148 221 108T330 68Q404 68 440 107T476 228V689H572V221ZM250 894T266 878T283 837Q283 813 267 797T226
+780Q201 780 185 796T168 837Q168 861 184 877T226 894Q250 894 266 878ZM460 894T476 878T493 837Q493 813 477 797T435 780Q411 780 395 796T378 837Q378 861 394 877T435 894Q460 894 476 878Z" />
+<glyph unicode="Ý" glyph-name="Yacute" horiz-adv-x="550" d="M545 689L323 265V0H227V264L5 689H110L278 348L446 689H545ZM355 911L395 834L179 755L155 804L355 911Z" />
+<glyph unicode="Þ" glyph-name="Thorn" horiz-adv-x="581" d="M409 571T479 517T549 354Q549 238 476 183T282 127H195V0H100V689H195V571H281Q409 571 479 517ZM362 202T405 235T448 353Q448 430 405 463T280 497H195V202H278Q362 202 405 235Z" />
+<glyph unicode="ß" glyph-name="germandbls" horiz-adv-x="593" d="M351 750T391 731T454 680T476 607Q476 566 459 542T410 492Q386 472 376 459T365 427Q365 404 382 387T434 346Q472 320 495 299T536 244T553 162Q553 110 529 71T463 10T375 -12Q316 -12
+273 11L300 75Q326 62 366 62Q408 62 433 88T459 163Q459 208 436 236T366 297Q323 328 301 354T278 420Q278 453 292 472T335 515Q362 537 375 555T388 602Q388 639 362 658T295 678Q187 678 187 539V0H95V539Q95 639 147 694T296 750Q351 750 391 731Z" />
+<glyph unicode="à" glyph-name="agrave" horiz-adv-x="544" d="M450 91T461 76T494 52L473 -12Q432 -7 407 11T370 67Q317 -12 213 -12Q135 -12 90 32T45 147Q45 231 105 276T277 321H358V360Q358 416 331 440T248 464Q190 464 106 436L83 503Q181 539 265
+539Q358 539 404 494T450 364V123Q450 91 461 76ZM313 57T358 139V260H289Q143 260 143 152Q143 105 166 81T234 57Q313 57 358 139ZM192 801L391 687L363 638L151 724L192 801Z" />
+<glyph unicode="á" glyph-name="aacute" horiz-adv-x="544" d="M450 91T461 76T494 52L473 -12Q432 -7 407 11T370 67Q317 -12 213 -12Q135 -12 90 32T45 147Q45 231 105 276T277 321H358V360Q358 416 331 440T248 464Q190 464 106 436L83 503Q181 539 265
+539Q358 539 404 494T450 364V123Q450 91 461 76ZM313 57T358 139V260H289Q143 260 143 152Q143 105 166 81T234 57Q313 57 358 139ZM340 801L381 724L169 638L141 687L340 801Z" />
+<glyph unicode="â" glyph-name="acircumflex" horiz-adv-x="544" d="M450 91T461 76T494 52L473 -12Q432 -7 407 11T370 67Q317 -12 213 -12Q135 -12 90 32T45 147Q45 231 105 276T277 321H358V360Q358 416 331 440T248 464Q190 464 106 436L83 503Q181 539
+265 539Q358 539 404 494T450 364V123Q450 91 461 76ZM313 57T358 139V260H289Q143 260 143 152Q143 105 166 81T234 57Q313 57 358 139ZM134 634L95 679L230 792H291L427 679L387 634L261 718L134 634Z" />
+<glyph unicode="ã" glyph-name="atilde" horiz-adv-x="544" d="M450 91T461 76T494 52L473 -12Q432 -7 407 11T370 67Q317 -12 213 -12Q135 -12 90 32T45 147Q45 231 105 276T277 321H358V360Q358 416 331 440T248 464Q190 464 106 436L83 503Q181 539 265
+539Q358 539 404 494T450 364V123Q450 91 461 76ZM313 57T358 139V260H289Q143 260 143 152Q143 105 166 81T234 57Q313 57 358 139ZM300 656T285 663T250 683Q235 694 225 699T203 704Q187 704 175 693T150 658L94 686Q113 726 140 750T203 774Q224 774 239 767T273
+746Q276 744 285 738T303 729T319 726Q334 726 346 736T372 770L428 742Q409 700 381 678T319 656Q300 656 285 663Z" />
+<glyph unicode="ä" glyph-name="adieresis" horiz-adv-x="544" d="M450 91T461 76T494 52L473 -12Q432 -7 407 11T370 67Q317 -12 213 -12Q135 -12 90 32T45 147Q45 231 105 276T277 321H358V360Q358 416 331 440T248 464Q190 464 106 436L83 503Q181 539
+265 539Q358 539 404 494T450 364V123Q450 91 461 76ZM313 57T358 139V260H289Q143 260 143 152Q143 105 166 81T234 57Q313 57 358 139ZM180 768T196 752T213 711Q213 687 197 671T156 654Q131 654 115 670T98 711Q98 735 114 751T156 768Q180 768 196 752ZM390
+768T406 752T423 711Q423 687 407 671T365 654Q341 654 325 670T308 711Q308 735 324 751T365 768Q390 768 406 752Z" />
+<glyph unicode="å" glyph-name="aring" horiz-adv-x="544" d="M450 91T461 76T494 52L473 -12Q432 -7 407 11T370 67Q317 -12 213 -12Q135 -12 90 32T45 147Q45 231 105 276T277 321H358V360Q358 416 331 440T248 464Q190 464 106 436L83 503Q181 539 265
+539Q358 539 404 494T450 364V123Q450 91 461 76ZM313 57T358 139V260H289Q143 260 143 152Q143 105 166 81T234 57Q313 57 358 139ZM311 836T343 806T375 730Q375 685 343 655T261 624Q211 624 179 654T147 730Q147 775 179 805T261 836Q311 836 343 806ZM236
+786T222 771T208 730Q208 704 222 689T261 674Q285 674 299 689T314 730Q314 756 300 771T261 786Q236 786 222 771Z" />
+<glyph unicode="æ" glyph-name="ae" horiz-adv-x="849" d="M797 256T795 232H459Q465 145 503 104T601 63Q639 63 671 74T738 109L778 54Q694 -12 594 -12Q531 -12 483 13T404 85Q368 33 323 11T216 -12Q137 -12 91 32T45 147Q45 231 107 276T280 321H361V360Q361
+416 334 440T251 464Q193 464 109 436L86 503Q184 539 268 539Q382 539 425 455Q482 539 584 539Q686 539 741 470T797 279Q797 256 795 232ZM706 306Q706 384 675 425T582 466Q469 466 459 300H706V306ZM279 57T312 79T376 149Q361 197 361 257V260H292Q146 260
+146 152Q146 105 169 81T237 57Q279 57 312 79Z" />
+<glyph unicode="ç" glyph-name="ccedilla" horiz-adv-x="478" d="M385 -5T308 -11V-56Q356 -60 378 -83T401 -141Q401 -189 366 -215T277 -241Q249 -241 225 -235T186 -217L211 -165Q241 -181 274 -181Q297 -181 310 -172T324 -141Q324 -120 303 -110T235
+-99L246 -9Q157 5 107 75T57 259Q57 343 85 406T164 504T287 539Q334 539 373 526T448 482L404 424Q376 444 350 453T291 463Q227 463 192 412T156 261Q156 161 191 114T291 66Q322 66 348 75T406 106L448 46Q385 -5 308 -11Z" />
+<glyph unicode="è" glyph-name="egrave" horiz-adv-x="545" d="M493 256T491 232H155Q161 145 199 104T297 63Q335 63 367 74T434 109L474 54Q390 -12 290 -12Q180 -12 119 60T57 258Q57 340 83 403T159 503T276 539Q381 539 437 470T493 279Q493 256 491
+232ZM402 306Q402 384 371 425T278 466Q165 466 155 300H402V306ZM210 801L409 687L381 638L169 724L210 801Z" />
+<glyph unicode="é" glyph-name="eacute" horiz-adv-x="545" d="M493 256T491 232H155Q161 145 199 104T297 63Q335 63 367 74T434 109L474 54Q390 -12 290 -12Q180 -12 119 60T57 258Q57 340 83 403T159 503T276 539Q381 539 437 470T493 279Q493 256 491
+232ZM402 306Q402 384 371 425T278 466Q165 466 155 300H402V306ZM358 801L399 724L187 638L159 687L358 801Z" />
+<glyph unicode="ê" glyph-name="ecircumflex" horiz-adv-x="545" d="M493 256T491 232H155Q161 145 199 104T297 63Q335 63 367 74T434 109L474 54Q390 -12 290 -12Q180 -12 119 60T57 258Q57 340 83 403T159 503T276 539Q381 539 437 470T493 279Q493 256
+491 232ZM402 306Q402 384 371 425T278 466Q165 466 155 300H402V306ZM152 634L113 679L248 792H309L445 679L405 634L279 718L152 634Z" />
+<glyph unicode="ë" glyph-name="edieresis" horiz-adv-x="545" d="M493 256T491 232H155Q161 145 199 104T297 63Q335 63 367 74T434 109L474 54Q390 -12 290 -12Q180 -12 119 60T57 258Q57 340 83 403T159 503T276 539Q381 539 437 470T493 279Q493 256
+491 232ZM402 306Q402 384 371 425T278 466Q165 466 155 300H402V306ZM198 768T214 752T231 711Q231 687 215 671T174 654Q149 654 133 670T116 711Q116 735 132 751T174 768Q198 768 214 752ZM408 768T424 752T441 711Q441 687 425 671T383 654Q359 654 343 670T326
+711Q326 735 342 751T383 768Q408 768 424 752Z" />
+<glyph unicode="ì" glyph-name="igrave" horiz-adv-x="282" d="M187 527V0H95V527H187ZM72 801L271 687L243 638L31 724L72 801Z" />
+<glyph unicode="í" glyph-name="iacute" horiz-adv-x="282" d="M187 527V0H95V527H187ZM220 801L261 724L49 638L21 687L220 801Z" />
+<glyph unicode="î" glyph-name="icircumflex" horiz-adv-x="282" d="M187 527V0H95V527H187ZM14 634L-25 679L110 792H171L307 679L267 634L141 718L14 634Z" />
+<glyph unicode="ï" glyph-name="idieresis" horiz-adv-x="282" d="M187 527V0H95V527H187ZM60 768T76 752T93 711Q93 687 77 671T36 654Q11 654 -5 670T-22 711Q-22 735 -6 751T36 768Q60 768 76 752ZM270 768T286 752T303 711Q303 687 287 671T245 654Q221
+654 205 670T188 711Q188 735 204 751T245 768Q270 768 286 752Z" />
+<glyph unicode="ð" glyph-name="eth" horiz-adv-x="570" d="M432 596T470 501T508 265Q508 182 479 120T398 23T278 -12Q216 -12 166 17T86 102T57 235Q57 297 79 352T147 441T258 475Q349 475 405 408Q393 471 365 519T286 607L214 537L151 569L225 644Q173
+668 112 680L132 750Q217 733 281 702L351 776L405 729L342 664Q432 596 470 501ZM340 61T377 114T415 266Q415 287 413 325Q387 364 353 383T272 403Q151 403 151 239Q151 153 185 107T277 61Q340 61 377 114Z" />
+<glyph unicode="ñ" glyph-name="ntilde" horiz-adv-x="586" d="M415 539T455 496T496 378V0H404V365Q404 421 383 444T321 467Q279 467 247 443T187 374V0H95V527H174L182 449Q210 491 251 515T343 539Q415 539 455 496ZM337 656T322 663T287 683Q272 694
+262 699T240 704Q224 704 212 693T187 658L131 686Q150 726 177 750T240 774Q261 774 276 767T310 746Q313 744 322 738T340 729T356 726Q371 726 383 736T409 770L465 742Q446 700 418 678T356 656Q337 656 322 663Z" />
+<glyph unicode="ò" glyph-name="ograve" horiz-adv-x="584" d="M404 539T465 465T527 264Q527 182 499 120T418 23T292 -12Q181 -12 119 62T57 263Q57 345 85 407T166 504T293 539Q404 539 465 465ZM156 465T156 263Q156 62 292 62Q428 62 428 264Q428 465
+293 465Q156 465 156 263ZM223 801L422 687L394 638L182 724L223 801Z" />
+<glyph unicode="ó" glyph-name="oacute" horiz-adv-x="584" d="M404 539T465 465T527 264Q527 182 499 120T418 23T292 -12Q181 -12 119 62T57 263Q57 345 85 407T166 504T293 539Q404 539 465 465ZM156 465T156 263Q156 62 292 62Q428 62 428 264Q428 465
+293 465Q156 465 156 263ZM371 801L412 724L200 638L172 687L371 801Z" />
+<glyph unicode="ô" glyph-name="ocircumflex" horiz-adv-x="584" d="M404 539T465 465T527 264Q527 182 499 120T418 23T292 -12Q181 -12 119 62T57 263Q57 345 85 407T166 504T293 539Q404 539 465 465ZM156 465T156 263Q156 62 292 62Q428 62 428 264Q428
+465 293 465Q156 465 156 263ZM165 634L126 679L261 792H322L458 679L418 634L292 718L165 634Z" />
+<glyph unicode="õ" glyph-name="otilde" horiz-adv-x="584" d="M404 539T465 465T527 264Q527 182 499 120T418 23T292 -12Q181 -12 119 62T57 263Q57 345 85 407T166 504T293 539Q404 539 465 465ZM156 465T156 263Q156 62 292 62Q428 62 428 264Q428 465
+293 465Q156 465 156 263ZM331 656T316 663T281 683Q266 694 256 699T234 704Q218 704 206 693T181 658L125 686Q144 726 171 750T234 774Q255 774 270 767T304 746Q307 744 316 738T334 729T350 726Q365 726 377 736T403 770L459 742Q440 700 412 678T350 656Q331
+656 316 663Z" />
+<glyph unicode="ö" glyph-name="odieresis" horiz-adv-x="584" d="M404 539T465 465T527 264Q527 182 499 120T418 23T292 -12Q181 -12 119 62T57 263Q57 345 85 407T166 504T293 539Q404 539 465 465ZM156 465T156 263Q156 62 292 62Q428 62 428 264Q428
+465 293 465Q156 465 156 263ZM211 768T227 752T244 711Q244 687 228 671T187 654Q162 654 146 670T129 711Q129 735 145 751T187 768Q211 768 227 752ZM421 768T437 752T454 711Q454 687 438 671T396 654Q372 654 356 670T339 711Q339 735 355 751T396 768Q421
+768 437 752Z" />
+<glyph unicode="÷" glyph-name="divide" horiz-adv-x="500" d="M280 174T300 154T320 105Q320 76 300 56T250 35Q221 35 201 55T181 105Q181 134 201 154T250 174Q280 174 300 154ZM280 631T300 611T320 562Q320 533 300 513T250 492Q221 492 201 512T181
+562Q181 591 201 611T250 631Q280 631 300 611ZM62 294V371H438V294H62Z" />
+<glyph unicode="ø" glyph-name="oslash" horiz-adv-x="584" d="M470 475T498 413T527 264Q527 182 499 120T418 23T292 -12Q268 -12 241 -7L202 -130L127 -108L169 19Q115 52 86 115T57 263Q57 345 85 407T166 504T293 539Q317 539 344 534L383 656L458 634L416
+508Q470 475 498 413ZM156 465T156 263Q156 134 204 89L328 462Q311 465 293 465Q156 465 156 263ZM428 62T428 264Q428 331 417 373T381 437L258 65Q273 62 292 62Q428 62 428 264Z" />
+<glyph unicode="ù" glyph-name="ugrave" horiz-adv-x="582" d="M487 0H408L401 82Q371 33 332 11T237 -12Q168 -12 129 30T90 149V527H182V159Q182 105 201 83T263 60Q340 60 395 151V527H487V0ZM220 801L419 687L391 638L179 724L220 801Z" />
+<glyph unicode="ú" glyph-name="uacute" horiz-adv-x="582" d="M487 0H408L401 82Q371 33 332 11T237 -12Q168 -12 129 30T90 149V527H182V159Q182 105 201 83T263 60Q340 60 395 151V527H487V0ZM368 801L409 724L197 638L169 687L368 801Z" />
+<glyph unicode="û" glyph-name="ucircumflex" horiz-adv-x="582" d="M487 0H408L401 82Q371 33 332 11T237 -12Q168 -12 129 30T90 149V527H182V159Q182 105 201 83T263 60Q340 60 395 151V527H487V0ZM162 634L123 679L258 792H319L455 679L415 634L289 718L162
+634Z" />
+<glyph unicode="ü" glyph-name="udieresis" horiz-adv-x="582" d="M487 0H408L401 82Q371 33 332 11T237 -12Q168 -12 129 30T90 149V527H182V159Q182 105 201 83T263 60Q340 60 395 151V527H487V0ZM208 768T224 752T241 711Q241 687 225 671T184 654Q159
+654 143 670T126 711Q126 735 142 751T184 768Q208 768 224 752ZM418 768T434 752T451 711Q451 687 435 671T393 654Q369 654 353 670T336 711Q336 735 352 751T393 768Q418 768 434 752Z" />
+<glyph unicode="ý" glyph-name="yacute" horiz-adv-x="492" d="M306 -3Q275 -95 220 -148T61 -213L51 -141Q103 -132 134 -115T183 -72T218 0H187L10 527H108L249 67L387 527H482L306 -3ZM325 801L366 724L154 638L126 687L325 801Z" />
+<glyph unicode="þ" glyph-name="thorn" horiz-adv-x="594" d="M438 539T485 467T532 264Q532 140 478 64T325 -12Q237 -12 187 48V-198L95 -213V739L187 750V463Q215 500 254 519T337 539Q438 539 485 467ZM433 63T433 264Q433 466 314 466Q275 466 243 443T187
+384V127Q207 96 237 80T303 63Q433 63 433 264Z" />
+<glyph unicode="ÿ" glyph-name="ydieresis" horiz-adv-x="492" d="M306 -3Q275 -95 220 -148T61 -213L51 -141Q103 -132 134 -115T183 -72T218 0H187L10 527H108L249 67L387 527H482L306 -3ZM165 768T181 752T198 711Q198 687 182 671T141 654Q116 654 100
+670T83 711Q83 735 99 751T141 768Q165 768 181 752ZM375 768T391 752T408 711Q408 687 392 671T350 654Q326 654 310 670T293 711Q293 735 309 751T350 768Q375 768 391 752Z" />
+<glyph unicode="–" glyph-name="endash" horiz-adv-x="520" d="M32 274V352H488V274H32Z" />
+<glyph unicode="—" glyph-name="emdash" horiz-adv-x="790" d="M32 274V352H758V274H32Z" />
+<glyph unicode="‘" glyph-name="quoteleft" horiz-adv-x="228" d="M82 490T63 508T44 553Q44 565 47 577T61 611L128 753H188L148 603Q174 583 174 553Q174 527 155 509T109 490Q82 490 63 508Z" />
+<glyph unicode="’" glyph-name="quoteright" horiz-adv-x="228" d="M146 753T165 735T184 690Q184 678 181 666T167 632L100 490H40L80 640Q54 660 54 690Q54 716 73 734T119 753Q146 753 165 735Z" />
+<glyph unicode="‚" glyph-name="quotesinglbase" horiz-adv-x="228" d="M146 107T165 89T184 44Q184 32 181 20T167 -14L100 -156H40L80 -6Q54 14 54 44Q54 70 73 88T119 107Q146 107 165 89Z" />
+<glyph unicode="“" glyph-name="quotedblleft" horiz-adv-x="406" d="M82 490T63 508T44 553Q44 565 47 577T61 611L128 753H188L148 603Q174 583 174 553Q174 527 155 509T109 490Q82 490 63 508ZM260 490T241 508T222 553Q222 565 225 577T239 611L306
+753H366L326 603Q352 583 352 553Q352 527 333 509T287 490Q260 490 241 508Z" />
+<glyph unicode="”" glyph-name="quotedblright" horiz-adv-x="406" d="M146 753T165 735T184 690Q184 678 181 666T167 632L100 490H40L80 640Q54 660 54 690Q54 716 73 734T119 753Q146 753 165 735ZM324 753T343 735T362 690Q362 678 359 666T345 632L278
+490H218L258 640Q232 660 232 690Q232 716 251 734T297 753Q324 753 343 735Z" />
+<glyph unicode="„" glyph-name="quotedblbase" horiz-adv-x="406" d="M146 107T165 89T184 44Q184 32 181 20T167 -14L100 -156H40L80 -6Q54 14 54 44Q54 70 73 88T119 107Q146 107 165 89ZM324 107T343 89T362 44Q362 32 359 20T345 -14L278 -156H218L258
+-6Q232 14 232 44Q232 70 251 88T297 107Q324 107 343 89Z" />
+<glyph unicode="•" glyph-name="bullet" horiz-adv-x="324" d="M210 454T242 422T274 341Q274 293 242 261T162 229Q114 229 82 261T50 342Q50 390 82 422T162 454Q210 454 242 422Z" />
+<glyph unicode="‹" glyph-name="guilsinglleft" horiz-adv-x="340" d="M230 535L285 497L150 287L285 77L230 39L55 255V318L230 535Z" />
+<glyph unicode="›" glyph-name="guilsinglright" horiz-adv-x="340" d="M110 535L285 318V255L110 39L55 77L190 287L55 497L110 535Z" />
+</font>
+</defs>
+</svg>
--- /dev/null
+\ifouthtml
+\begin{rawhtml}
+<ul>
+<li><a HREF=libref/index_modules.html>Index of modules</a></li>
+<li><a HREF=libref/index_module_types.html>Index of module types</a></li>
+<li><a HREF=libref/index_types.html>Index of types</a></li>
+<li><a HREF=libref/index_exceptions.html>Index of exceptions</a></li>
+<li><a HREF=libref/index_values.html>Index of values</a></li>
+</ul>
+\end{rawhtml}
+\else
+\chapter*{Index to the library}
+\markright{Index to the library}
+\addcontentsline{toc}{chapter}{Index to the library}
+\myprintindex{\jobname.ind}
+\fi
+\chapter*{Index of keywords}
+\markright{Index of keywords}
+\addcontentsline{toc}{chapter}{Index of keywords}
+\myprintindex{\jobname.kwd.ind}
--- /dev/null
+*.haux
+*.hind
+*.info*.gz
+*.info.body*
+ocaml.hocaml.kwd
--- /dev/null
+*.tex
+*.htex
+arithstatus.mli
+ocamldoc.out
+ocamldoc.sty
--- /dev/null
+*.tex
+*.htex
+arithstatus.mli
+ocamldoc.out
+ocamldoc.sty
--- /dev/null
+CORE_INTF=Pervasives.tex
+
+CSLDIR=$(RELEASEDIR)
+
+STDLIB_INTF= Arg.tex Array.tex ArrayLabels.tex Char.tex Complex.tex \
+ Digest.tex Filename.tex Format.tex \
+ Gc.tex Genlex.tex Hashtbl.tex Int32.tex Int64.tex \
+ Lazy.tex Lexing.tex List.tex ListLabels.tex Map.tex Marshal.tex \
+ MoreLabels.tex Nativeint.tex Obj.tex Oo.tex \
+ Parsing.tex Printexc.tex Printf.tex Queue.tex Random.tex Scanf.tex \
+ Set.tex Sort.tex Stack.tex Stream.tex String.tex StringLabels.tex Sys.tex \
+ Weak.tex Callback.tex Buffer.tex StdLabels.tex \
+ Bytes.tex BytesLabels.tex Spacetime.tex
+
+COMPILER_LIBS_PLUGIN_HOOKS=Pparse.tex Typemod.tex
+
+COMPILER_LIBS_INTF=Asthelper.tex Astmapper.tex Asttypes.tex \
+ Lexer.tex Location.tex Longident.tex Parse.tex Pprintast.tex Printast.tex \
+ $(COMPILER_LIBS_PLUGIN_HOOKS)
+
+OTHERLIB_INTF=Unix.tex UnixLabels.tex Str.tex \
+ Graphics.tex GraphicsX11.tex \
+ Thread.tex Mutex.tex Condition.tex Event.tex ThreadUnix.tex \
+ Dynlink.tex Bigarray.tex
+
+INTF=$(CORE_INTF) $(STDLIB_INTF) $(COMPILER_LIBS_INTF) $(OTHERLIB_INTF)
+
+BLURB=core.tex builtin.tex stdlib.tex compilerlibs.tex \
+ libunix.tex libstr.tex libnum.tex libgraph.tex \
+ libthreads.tex libdynlink.tex libbigarray.tex
+
+FILES=$(BLURB) $(INTF)
+
+SRC=../../..
+
+LD_PATH := $(SRC)/otherlibs/unix/:$(SRC)/otherlibs/str/
+SET_LD_PATH=CAML_LD_LIBRARY_PATH=$(LD_PATH)
+
+FORMAT=../../tools/format-intf
+TEXQUOTE=../../tools/texquote2
+
+VPATH=.:$(STDLIB_DIR):$(CSLDIR)/parsing:$(CSLDIR)/otherlibs/unix:$(CSLDIR)/otherlibs/str:$(CSLDIR)/otherlibs/graph:$(CSLDIR)/otherlibs/threads:$(CSLDIR)/otherlibs/dynlink:$(CSLDIR)/otherlibs/bigarray
+
+etex-files: $(BLURB)
+all: libs
+
+libs: $(FILES)
+
+OCAMLDOC=$(if $(wildcard $(CSLDIR)/ocamldoc/ocamldoc.opt),\
+ $(CSLDIR)/ocamldoc/ocamldoc.opt,\
+ $(SET_LD_PATH) $(CSLDIR)/byterun/ocamlrun $(CSLDIR)/ocamldoc/ocamldoc) \
+ -nostdlib -initially-opened-module Pervasives
+
+# Copy and unprefix the standard library when needed
+include $(SRC)/ocamldoc/Makefile.unprefix
+
+
+$(INTF): interfaces
+interfaces: $(STDLIB_CMIS)
+ $(OCAMLDOC) -latex \
+ -I $(STDLIB_UNPREFIXED) \
+ $(STDLIB_MLIS) \
+ -sepfiles \
+ -latextitle "1,subsection*" \
+ -latextitle "2,subsubsection*" \
+ -latex-type-prefix "TYP" \
+ -latex-module-prefix "" \
+ -latex-module-type-prefix "" \
+ -latex-value-prefix ""
+ mv -f Ast_helper.tex Asthelper.tex
+ mv -f Ast_mapper.tex Astmapper.tex
+
+clean:
+ rm -f $(FILES)
+
+.SUFFIXES:
+.SUFFIXES: .tex .etex .mli
+
+.etex.tex: $(TEXQUOTE)
+ @$(TEXQUOTE) < $*.etex > $*.texquote_error.tex\
+ && mv $*.texquote_error.tex $*.tex\
+ || printf "Failure when generating %s\n" $*.tex
+
+
+.mli.tex: $(FORMAT)
+ $(FORMAT) $< > $*.tex < $<
--- /dev/null
+\section{Built-in types and predefined exceptions}
+
+The following built-in types and predefined exceptions are always
+defined in the
+compilation environment, but are not part of any module. As a
+consequence, they can only be referred by their short names.
+
+%\vspace{0.1cm}
+\subsection*{Built-in types}
+%\vspace{0.1cm}
+
+\begin{ocamldoccode}
+ type int
+\end{ocamldoccode}
+\index{int@\verb`int`}
+\begin{ocamldocdescription}
+ The type of integer numbers.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+ type char
+\end{ocamldoccode}
+\index{char@\verb`char`}
+\begin{ocamldocdescription}
+ The type of characters.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+ type bytes
+\end{ocamldoccode}
+\index{bytes@\verb`bytes`}
+\begin{ocamldocdescription}
+ The type of (writable) byte sequences.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+ type string
+\end{ocamldoccode}
+\index{string@\verb`string`}
+\begin{ocamldocdescription}
+ The type of (read-only) character strings.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+ type float
+\end{ocamldoccode}
+\index{float@\verb`float`}
+\begin{ocamldocdescription}
+ The type of floating-point numbers.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+ type bool = false | true
+\end{ocamldoccode}
+\index{bool@\verb`bool`}
+\begin{ocamldocdescription}
+ The type of booleans (truth values).
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+ type unit = ()
+\end{ocamldoccode}
+\index{unit@\verb`unit`}
+\begin{ocamldocdescription}
+ The type of the unit value.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+ type exn
+\end{ocamldoccode}
+\index{exn@\verb`exn`}
+\begin{ocamldocdescription}
+ The type of exception values.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+ type 'a array
+\end{ocamldoccode}
+\index{array@\verb`array`}
+\begin{ocamldocdescription}
+ The type of arrays whose elements have type "'a".
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+ type 'a list = [] | :: of 'a * 'a list
+\end{ocamldoccode}
+\index{list@\verb`list`}
+\begin{ocamldocdescription}
+ The type of lists whose elements have type "'a".
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+type 'a option = None | Some of 'a
+\end{ocamldoccode}
+\index{option@\verb`option`}
+\begin{ocamldocdescription}
+ The type of optional values of type "'a".
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+type int32
+\end{ocamldoccode}
+\index{int32@\verb`int32`}
+\begin{ocamldocdescription}
+ The type of signed 32-bit integers.
+ See the "Int32"[\moduleref{Int32}] module.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+type int64
+\end{ocamldoccode}
+\index{int64@\verb`int64`}
+\begin{ocamldocdescription}
+ The type of signed 64-bit integers.
+ See the "Int64"[\moduleref{Int64}] module.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+type nativeint
+\end{ocamldoccode}
+\index{nativeint@\verb`nativeint`}
+\begin{ocamldocdescription}
+ The type of signed, platform-native integers (32 bits on 32-bit
+ processors, 64 bits on 64-bit processors).
+ See the "Nativeint"[\moduleref{Nativeint}] module.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+type ('a, 'b, 'c, 'd, 'e, 'f) format6
+\end{ocamldoccode}
+\index{format4@\verb`format4`}
+\begin{ocamldocdescription}
+ The type of format strings. "'a" is the type of the parameters of
+ the format, "'f" is the result type for the "printf"-style
+ functions, "'b" is the type of the first argument given to "%a" and
+ "%t" printing functions (see module "Printf"[\moduleref{Printf}]),
+ "'c" is the result type of these functions, and also the type of the
+ argument transmitted to the first argument of "kprintf"-style
+ functions, "'d" is the result type for the "scanf"-style functions
+ (see module "Scanf"[\moduleref{Scanf}]),
+ and "'e" is the type of the receiver function for the "scanf"-style
+ functions.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+type 'a lazy_t
+\end{ocamldoccode}
+\index{lazyt@\verb`lazy_t`}
+\begin{ocamldocdescription}
+ This type is used to implement the "Lazy"[\moduleref{Lazy}] module.
+ It should not be used directly.
+\end{ocamldocdescription}
+
+%\vspace{0.1cm}
+\subsection*{Predefined exceptions}
+%\vspace{0.1cm}
+
+\begin{ocamldoccode}
+exception Match_failure of (string * int * int)
+\end{ocamldoccode}
+\index{Matchfailure@\verb`Match_failure`}
+\begin{ocamldocdescription}
+ Exception raised when none of the cases of a pattern-matching
+ apply. The arguments are the location of the "match" keyword
+ in the source code (file name, line number, column number).
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+exception Assert_failure of (string * int * int)
+\end{ocamldoccode}
+\index{Assertfailure@\verb`Assert_failure`}
+\begin{ocamldocdescription}
+ Exception raised when an assertion fails. The arguments are
+ the location of the "assert" keyword in the source code
+ (file name, line number, column number).
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+exception Invalid_argument of string
+\end{ocamldoccode}
+\index{Invalidargument@\verb`Invalid_argument`}
+\begin{ocamldocdescription}
+ Exception raised by library functions to signal that the given
+ arguments do not make sense. The string gives some information
+ to the programmer. As a general rule, this exception should not
+ be caught, it denotes a programming error and the code should be
+ modified not to trigger it.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+exception Failure of string
+\end{ocamldoccode}
+\index{Failure@\verb`Failure`}
+\begin{ocamldocdescription}
+ Exception raised by library functions to signal that they are
+ undefined on the given arguments. The string is meant to give some
+ information to the programmer; you must \emph{not} pattern match on
+ the string literal because it may change in future versions (use
+ \verb`Failure _` instead).
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+exception Not_found
+\end{ocamldoccode}
+\index{Notfound@\verb`Not_found`}
+\begin{ocamldocdescription}
+ Exception raised by search functions when the desired object
+ could not be found.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+exception Out_of_memory
+\end{ocamldoccode}
+\index{Outofmemory@\verb`Out_of_memory`}
+\begin{ocamldocdescription}
+ Exception raised by the garbage collector
+ when there is insufficient memory to complete the computation.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+exception Stack_overflow
+\end{ocamldoccode}
+\index{Stackoverflow@\verb`Stack_overflow`}
+\begin{ocamldocdescription}
+ Exception raised by the bytecode interpreter when the evaluation
+ stack reaches its maximal size. This often indicates infinite
+ or excessively deep recursion in the user's program.
+ (Not fully implemented by the native-code compiler;
+ see section~\ref{s:compat-native-bytecode}.)
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+exception Sys_error of string
+\end{ocamldoccode}
+\index{Syserror@\verb`Sys_error`}
+\begin{ocamldocdescription}
+ Exception raised by the input/output functions to report an
+ operating system error. The string is meant to give some
+ information to the programmer; you must \emph{not} pattern match on
+ the string literal because it may change in future versions (use
+ \verb`Sys_error _` instead).
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+exception End_of_file
+\end{ocamldoccode}
+\index{Endoffile@\verb`End_of_file`}
+\begin{ocamldocdescription}
+ Exception raised by input functions to signal that the
+ end of file has been reached.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+exception Division_by_zero
+\end{ocamldoccode}
+\index{Divisionbyzero@\verb`Division_by_zero`}
+\begin{ocamldocdescription}
+ Exception raised by integer division and remainder operations
+ when their second argument is zero.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+exception Sys_blocked_io
+\end{ocamldoccode}
+\index{Sysblockedio@\verb`Sys_blocked_io`}
+\begin{ocamldocdescription}
+ A special case of "Sys_error" raised when no I/O is possible
+ on a non-blocking I/O channel.
+\end{ocamldocdescription}
+
+\begin{ocamldoccode}
+exception Undefined_recursive_module of (string * int * int)
+\end{ocamldoccode}
+\index{Undefinedrecursivemodule@\verb`Undefined_recursive_module`}
+\begin{ocamldocdescription}
+ Exception raised when an ill-founded recursive module definition
+ is evaluated. (See section~\ref{s-recursive-modules}.)
+ The arguments are the location of the definition in the source code
+ (file name, line number, column number).
+\end{ocamldocdescription}
+
--- /dev/null
+\chapter{The compiler front-end} \label{c:parsinglib}\cutname{parsing.html}
+\pdfchapterfold{-1}{The compiler front-end}
+
+This chapter describes the OCaml front-end, which declares the abstract
+syntax tree used by the compiler, provides a way to parse, print
+and pretty-print OCaml code, and ultimately allows to write abstract
+syntax tree preprocessors invoked via the {\tt -ppx} flag (see chapters~\ref{c:camlc}
+and~\ref{c:nativecomp}) and plugins invoked via the {\tt -plugin} flag
+(see chapter~\ref{c:plugins}).
+
+It is important to note that the exported front-end interface follows the evolution of the OCaml language and implementation, and thus does not provide {\bf any} backwards compatibility guarantees.
+
+The front-end is a part of "compiler-libs" library.
+Programs that use the "compiler-libs" library should be built as follows:
+\begin{alltt}
+ ocamlfind ocamlc \var{other options} -package compiler-libs.common \var{other files}
+ ocamlfind ocamlopt \var{other options} -package compiler-libs.common \var{other files}
+\end{alltt}
+Use of the {\tt ocamlfind} utility is recommended. However, if this is not possible, an alternative method may be used:
+\begin{alltt}
+ ocamlc \var{other options} -I +compiler-libs ocamlcommon.cma \var{other files}
+ ocamlopt \var{other options} -I +compiler-libs ocamlcommon.cmxa \var{other files}
+\end{alltt}
+For interactive use of the "compiler-libs" library, start "ocaml" and
+type\\*"#load \"compiler-libs/ocamlcommon.cma\";;".
+
+% Some of the files below are commented out as the documentation is too poor
+% or they are thought to be nonessential.
+
+\ifouthtml
+\begin{links}
+\item \ahref{libref/Ast\_helper.html}{Module \texttt{Ast_helper}: helper functions for AST construction}
+\item \ahref{libref/Ast\_mapper.html}{Module \texttt{Ast_mapper}: -ppx rewriter interface}
+\item \ahref{libref/Asttypes.html}{Module \texttt{Asttypes}: auxiliary types used by Parsetree}
+% \item \ahref{libref/Lexer.html}{Module \texttt{Lexer}: OCaml syntax lexing}
+\item \ahref{libref/Location.html}{Module \texttt{Location}: source code locations}
+\item \ahref{libref/Longident.html}{Module \texttt{Longident}: long identifiers}
+\item \ahref{libref/Parse.html}{Module \texttt{Parse}: OCaml syntax parsing}
+\item \ahref{libref/Parsetree.html}{Module \texttt{Parsetree}: OCaml syntax tree}
+\item \ahref{libref/Pprintast.html}{Module \texttt{Pprintast}: OCaml syntax printing}
+% \item \ahref{libref/Printast.html}{Module \texttt{Printast}: AST printing}
+\end{links}
+
+\else
+% Ast_helper is excluded from the PDF and text manuals.
+% It is over 20 pages long and does not have doc-comments. It is expected
+% that Ast_helper will be only useful in the HTML manual (to look up signatures).
+% \input{Asthelper.tex}
+\input{Astmapper.tex}
+\input{Asttypes.tex}
+% \input{Lexer.tex}
+\input{Location.tex}
+\input{Longident.tex}
+\input{Parse.tex}
+\input{Parsetree.tex}
+\input{Pprintast.tex}
+% \input{Printast.tex}
+\fi
+
+\ifouthtml
+The following modules provides hooks for compiler plugins:
+\begin{links}
+\item \ahref{libref/Pparse.html}{Module \texttt{Pparse}: OCaml parser driver}
+\item \ahref{libref/Typemod.html}{Module \texttt{Typemod}:
+OCaml module type checking}
+\item \ahref{libref/Simplif.html}{Module \texttt{Simplif}: Lambda simplification}
+\item \ahref{libref/Clflags.html}{Module \texttt{Clflags}: command line flags}
+\end{links}
+\else
+\input{Pparse.tex}
+\input{Typemod.tex}
+\input{Simplif.tex}
+\input{Clflags.tex}
+\fi
--- /dev/null
+\chapter{The core library} \label{c:corelib}\cutname{core.html}
+\pdfchapterfold{-1}{The core library}
+
+This chapter describes the OCaml core library, which is
+ composed of declarations for built-in types and exceptions, plus
+the module "Pervasives" that provides basic operations on these
+ built-in types. The "Pervasives" module is special in two
+ways:
+\begin{itemize}
+\item It is automatically linked with the user's object code files by
+the "ocamlc" command (chapter~\ref{c:camlc}).
+
+\item It is automatically ``opened'' when a compilation starts, or
+when the toplevel system is launched. Hence, it is possible to use
+unqualified identifiers to refer to the functions provided by the
+"Pervasives" module, without adding a "open Pervasives" directive.
+\end{itemize}
+
+\section*{Conventions}
+
+The declarations of the built-in types and the components of module
+"Pervasives" are printed one by one in typewriter font, followed by a
+short comment. All library modules and the components they provide are
+indexed at the end of this report.
+
+\input{builtin.tex}
+
+\ifouthtml
+\section{Module {\tt Pervasives}: the initially opened module}
+\begin{links}
+\item \ahref{libref/Pervasives.html}{Module \texttt{Pervasives}: the initially opened module}
+\end{links}
+\else
+\input{Pervasives.tex}
+\fi
+
--- /dev/null
+\chapter{The bigarray library}
+\pdfchapterfold{-1}{The bigarray library}
+%HEVEA\cutname{libbigarray.html}
+
+The "bigarray" library has now been integrated into OCaml's standard
+library.
+
+The "bigarray" functionality may now be found in the standard library
+\ifouthtml
+ \ahref{libref/Bigarray.html}{\texttt{Bigarray} module},
+\else
+ \texttt{Bigarray} module,
+\fi
+except for the "map_file" function which is now
+part of the \hyperref[c:unix]{Unix library}. The documentation has
+been integrated into the documentation for the standard library.
+
+The legacy "bigarray" library bundled with the compiler is a
+compatibility library with exactly the same interface as before,
+i.e. with "map_file" included.
+
+We strongly recommend that you port your code to use the standard
+library version instead, as the changes required are minimal.
+
+If you choose to use the compatibility library, you must link your
+programs as follows:
+\begin{alltt}
+ ocamlc \var{other options} bigarray.cma \var{other files}
+ ocamlopt \var{other options} bigarray.cmxa \var{other files}
+\end{alltt}
+For interactive use of the "bigarray" compatibility library, do:
+\begin{alltt}
+ ocamlmktop -o mytop bigarray.cma
+ ./mytop
+\end{alltt}
+or (if dynamic linking of C libraries is supported on your platform),
+start "ocaml" and type "#load \"bigarray.cma\";;".
--- /dev/null
+\chapter{The dynlink library: dynamic loading and linking of object files}
+\pdfchapterfold{-1}{The dynlink library: dynamic loading and linking of object files}
+%HEVEA\cutname{libdynlink.html}
+
+The "dynlink" library supports type-safe dynamic loading and linking
+of bytecode object files (".cmo" and ".cma" files) in a running
+bytecode program, or of native plugins (usually ".cmxs" files) in a
+running native program. Type safety is ensured by limiting the set of
+modules from the running program that the loaded object file can
+access, and checking that the running program and the loaded object
+file have been compiled against the same interfaces for these modules.
+In native code, there are also some compatibility checks on the
+implementations (to avoid errors with cross-module optimizations); it
+might be useful to hide ".cmx" files when building native plugins so
+that they remain independent of the implementation of modules in the
+main program.
+
+Programs that use the "dynlink" library simply need to link
+"dynlink.cma" or "dynlink.cmxa" with their object files and other libraries.
+
+\ifouthtml
+\begin{links}
+\item \ahref{libref/Dynlink.html}{Module \texttt{Dynlink}: dynamic loading of bytecode object files}
+\end{links}
+
+\else
+\input{Dynlink.tex}
+\fi
+
--- /dev/null
+\chapter{The graphics library}
+\pdfchapterfold{-1}{The graphics library}
+%HEVEA\cutname{libgraph.html}
+
+The "graphics" library provides a set of portable drawing primitives.
+Drawing takes place
+in a separate window that is created when "Graphics.open_graph" is called.
+
+\begin{unix}
+This library is implemented under the X11 windows system.
+Programs that use the "graphics" library must be linked as follows:
+\begin{alltt}
+ ocamlc \var{other options} graphics.cma \var{other files}
+\end{alltt}
+For interactive use of the "graphics" library, do:
+\begin{alltt}
+ ocamlmktop -o mytop graphics.cma
+ ./mytop
+\end{alltt}
+or (if dynamic linking of C libraries is supported on your platform),
+start "ocaml" and type "#load \"graphics.cma\";;".
+
+Here are the graphics mode specifications supported by
+"Graphics.open_graph" on
+the X11 implementation of this library:
+the argument to "Graphics.open_graph" has the format
+"\""{\it display-name} {\it geometry\/}"\"",
+where {\it display-name} is the name of the X-windows display to
+connect to, and {\it geometry} is a standard X-windows geometry
+specification. The two components are separated by a space. Either can
+be omitted, or both. Examples:
+\begin{options}
+\item["Graphics.open_graph \"foo:0\""]
+connects to the display "foo:0" and creates a window with the default geometry
+\item["Graphics.open_graph \"foo:0 300x100+50-0\""]
+connects to the display "foo:0" and creates a window 300 pixels wide
+by 100 pixels tall, at location $(50,0)$
+\item["Graphics.open_graph \" 300x100+50-0\""]
+connects to the default display and creates a window 300 pixels wide
+by 100 pixels tall, at location $(50,0)$
+\item["Graphics.open_graph \"\""]
+connects to the default display and creates a window with the default
+geometry.
+\end{options}
+\end{unix}
+
+\begin{windows}
+This library is available both for standalone compiled programs and
+under the toplevel application "ocamlwin.exe". For the latter, this
+library must be loaded in-core by typing
+\begin{verbatim}
+ #load "graphics.cma";;
+\end{verbatim}
+\end{windows}
+
+The screen coordinates are interpreted as shown in the figure below.
+Notice that the coordinate system used is the same as in mathematics:
+$y$ increases from the bottom of the screen to the top of the screen,
+and angles are measured counterclockwise (in degrees).
+Drawing is clipped to the screen.
+%
+\begin{latexonly}
+\begin{center}
+\setlength{\unitlength}{0.5mm}
+\begin{picture}(130,100)(-10,-10)
+\thicklines
+\put(-10,0){\vector(1,0){130}}
+\put(125,0){\makebox(0,0)[l]{$x$}}
+\put(0,-10){\vector(0,1){100}}
+\put(0,95){\makebox(0,0){$y$}}
+\thinlines
+\put(100,80){\line(-1,0){105}}
+\put(100,80){\line(0,-1){85}}
+\put(95,75){\makebox(0,0)[tr]{Screen}}
+\put(100,-10){\makebox(0,0){\tt size\_x()}}
+\put(-10,80){\makebox(0,0)[r]{\tt size\_y()}}
+\put(30,40){\makebox(4,4){\rule{2mm}{2mm}}}
+\put(36,40){pixel at $(x,y)$}
+\put(30,40){\line(-1,0){35}}
+\put(30,-10){\makebox(0,0){$x$}}
+\put(30,40){\line(0,-1){45}}
+\put(-10,40){\makebox(0,0)[r]{$y$}}
+\end{picture}
+\end{center}
+\end{latexonly}
+
+\begin{htmlonly}
+\begin{center}
+\imgsrc{libgraph.gif}
+\end{center}
+\end{htmlonly}
+%
+
+\ifouthtml
+\begin{links}
+\item \ahref{libref/Graphics.html}{Module \texttt{Graphics}: machine-independent graphics primitives}
+\end{links}
+\else
+\input{Graphics.tex}
+\fi
--- /dev/null
+#FIG 3.2
+Landscape
+Center
+Inches
+Letter
+100.00
+Single
+-2
+1200 2
+2 1 0 1 0 7 0 0 -1 0.000 0 0 7 1 0 2
+ 1 1 1.00 60.00 120.00
+ 1050 3375 4575 3375
+2 1 0 1 0 7 0 0 -1 0.000 0 0 -1 1 0 2
+ 1 1 1.00 60.00 120.00
+ 1200 3525 1200 825
+2 1 0 1 0 7 0 0 -1 0.000 0 0 7 0 0 3
+ 1125 1200 3750 1200 3750 3450
+2 1 0 1 0 7 0 0 -1 0.000 0 0 -1 0 0 3
+ 1125 2400 2475 2400 2475 3450
+2 2 0 1 0 0 0 0 20 0.000 0 0 7 0 0 5
+ 2475 2400 2550 2400 2550 2325 2475 2325 2475 2400
+4 0 0 0 0 0 12 0.0000 4 135 525 2325 1500 Screen\001
+4 0 0 0 0 0 12 0.0000 4 180 990 2175 2250 point at (x,y)\001
+4 0 0 0 0 0 12 0.0000 4 90 90 2400 3600 x\001
+4 0 0 0 0 0 12 0.0000 4 135 90 975 2475 y\001
+4 0 0 0 0 0 12 0.0000 4 180 450 1050 750 y axis\001
+4 0 0 0 0 14 12 0.0000 4 180 840 225 1200 size_y()\001
+4 0 0 0 0 14 12 0.0000 4 165 840 3375 3600 size_x()\001
+4 0 0 0 0 0 12 0.0000 4 135 450 4650 3375 x axis\001
--- /dev/null
+\chapter{The num library: arbitrary-precision rational arithmetic}
+\pdfchapterfold{-3}{The num library: arbitrary-precision integer and rational arithmetic}
+%HEVEA\cutname{libnum.html}
+
+The "num" library implements integer arithmetic and rational
+arithmetic in arbitrary precision. It was split off the core
+OCaml distribution starting with the 4.06.0 release, and can now be found
+at \url{https://github.com/ocaml/num}.
+
+New applications that need arbitrary-precision arithmetic should use the
+"Zarith" library (\url{https://github.com/ocaml/Zarith}) instead of the "Num"
+library, and older applications that already use "Num" are encouraged to
+switch to "Zarith". "Zarith" delivers much better performance than "Num"
+and has a nicer API.
--- /dev/null
+\chapter{The str library: regular expressions and string processing}
+\pdfchapterfold{-1}{The str library: regular expressions and string processing}
+%HEVEA\cutname{libstr.html}
+
+The "str" library provides high-level string processing functions,
+some based on regular expressions. It is intended to support the kind
+of file processing that is usually performed with scripting languages
+such as "awk", "perl" or "sed".
+
+Programs that use the "str" library must be linked as follows:
+\begin{alltt}
+ ocamlc \var{other options} str.cma \var{other files}
+ ocamlopt \var{other options} str.cmxa \var{other files}
+\end{alltt}
+For interactive use of the "str" library, do:
+\begin{alltt}
+ ocamlmktop -o mytop str.cma
+ ./mytop
+\end{alltt}
+or (if dynamic linking of C libraries is supported on your platform),
+start "ocaml" and type "#load \"str.cma\";;".
+
+\ifouthtml
+\begin{links}
+\item \ahref{libref/Str.html}{Module \texttt{Str}: regular expressions and string processing}
+\end{links}
+
+\else
+\input{Str.tex}
+\fi
+
+
--- /dev/null
+\chapter{The threads library}
+\label{c:threads}\cutname{threads.html}
+\pdfchapterfold{-5}{The threads library}
+%HEVEA\cutname{libthreads.html}
+
+The "threads" library allows concurrent programming in OCaml.
+It provides multiple threads of control (also called lightweight
+processes) that execute concurrently in the same memory space. Threads
+communicate by in-place modification of shared data structures, or by
+sending and receiving data on communication channels.
+
+The "threads" library is implemented by time-sharing on a single
+processor. It will not take advantage of multi-processor machines.
+Using this library will therefore never make programs run
+faster. However, many programs are easier to write when structured as
+several communicating processes.
+
+Two implementations of the "threads" library are available, depending
+on the capabilities of the operating system:
+\begin{itemize}
+\item System threads. This implementation builds on the OS-provided threads
+facilities: POSIX 1003.1c threads for Unix, and Win32 threads for
+Windows. When available, system threads support both bytecode and
+native-code programs.
+\item VM-level threads. This implementation performs time-sharing and
+context switching at the level of the OCaml virtual machine (bytecode
+interpreter). It is available on Unix systems, and supports only
+bytecode programs. It cannot be used with native-code programs.
+\end{itemize}
+Programs that use system threads must be linked as follows:
+\begin{alltt}
+ ocamlc -I +threads \var{other options} unix.cma threads.cma \var{other files}
+ ocamlopt -I +threads \var{other options} unix.cmxa threads.cmxa \var{other files}
+\end{alltt}
+Compilation units that use the "threads" library must also be compiled with
+the "-I +threads" option (see chapter~\ref{c:camlc}).
+
+Programs that use VM-level threads must be compiled with the "-vmthread"
+option to "ocamlc" (see chapter~\ref{c:camlc}), and be linked as follows:
+\begin{alltt}
+ ocamlc -vmthread \var{other options} threads.cma \var{other files}
+\end{alltt}
+Compilation units that use "threads" library must also be compiled with
+the "-vmthread" option (see chapter~\ref{c:camlc}).
+
+\ifouthtml
+\begin{links}
+\item \ahref{libref/Thread.html}{Module \texttt{Thread}: lightweight threads}
+\item \ahref{libref/Mutex.html}{Module \texttt{Mutex}: locks for mutual exclusion}
+\item \ahref{libref/Condition.html}{Module \texttt{Condition}: condition variables to synchronize between threads}
+\item \ahref{libref/Event.html}{Module \texttt{Event}: first-class synchronous communication}
+\item \ahref{libref/ThreadUnix.html}{Module \texttt{ThreadUnix}: thread-compatible system calls}
+\end{links}
+\else
+\input{Thread.tex}
+\input{Mutex.tex}
+\input{Condition.tex}
+\input{Event.tex}
+\input{ThreadUnix.tex}
+\fi
--- /dev/null
+\chapter{The unix library: Unix system calls}
+\pdfchapterfold{-1}{The unix library: Unix system calls}
+%HEVEA\cutname{libunix.html}
+\label{c:unix}
+
+The "unix" library makes many Unix
+system calls and system-related library functions available to
+OCaml programs. This chapter describes briefly the functions
+provided. Refer to sections 2~and~3 of the Unix manual for more
+details on the behavior of these functions.
+
+\ifouthtml
+\begin{links}
+\item \ahref{libref/Unix.html}{Module \texttt{Unix}: Unix system calls}
+\item \ahref{libref/UnixLabels.html}{Module \texttt{UnixLabels}: Labeled
+ Unix system calls}
+\end{links}
+\fi
+
+Not all functions are provided by all Unix variants. If some functions
+are not available, they will raise "Invalid_arg" when called.
+
+Programs that use the "unix" library must be linked as follows:
+\begin{alltt}
+ ocamlc \var{other options} unix.cma \var{other files}
+ ocamlopt \var{other options} unix.cmxa \var{other files}
+\end{alltt}
+For interactive use of the "unix" library, do:
+\begin{alltt}
+ ocamlmktop -o mytop unix.cma
+ ./mytop
+\end{alltt}
+or (if dynamic linking of C libraries is supported on your platform),
+start "ocaml" and type "#load \"unix.cma\";;".
+
+\begin{windows}
+A fairly complete emulation of the Unix system calls is provided in
+the Windows version of OCaml. The end of this chapter gives
+more information on the functions that are not supported under Windows.
+\end{windows}
+
+\begin{latexonly}
+\input{Unix.tex}
+
+\section{Module \texttt{UnixLabels}: labelized version of the interface}
+\label{UnixLabels}
+\index{UnixLabels (module)@\verb~UnixLabels~ (module)}%
+\pdfsection{Module UnixLabels: labelized version of the interface}
+
+This module is identical to "Unix"~(\ref{Unix}), and only differs by
+the addition of labels. You may see these labels directly by looking
+at "unixLabels.mli", or by using the "ocamlbrowser" tool.
+
+\newpage
+\end{latexonly}
+
+\begin{windows}
+The Cygwin port of OCaml fully implements all functions from
+the Unix module. The native Win32 ports implement a subset of them.
+Below is a list of the functions that are not implemented, or only
+partially implemented, by the Win32 ports. Functions not mentioned are
+fully implemented and behave as described previously in this chapter.
+
+\begin{tableau}{|l|p{8cm}|}{Functions}{Comment}
+\entree{"fork"}{not implemented, use "create_process" or threads}
+\entree{"wait"}{not implemented, use "waitpid"}
+\entree{"waitpid"}{can only wait for a given PID, not any child process}
+\entree{"getppid"}{not implemented (meaningless under Windows)}
+\entree{"nice"}{not implemented}
+\entree{"truncate", "ftruncate"}{not implemented}
+\entree{"link"}{implemented (since 3.02)}
+\entree{"symlink", "readlink"}{implemented (since 4.03.0)}
+\entree{"access"}{execute permission "X_OK" cannot be tested,
+ it just tests for read permission instead}
+\entree{"fchmod"}{not implemented}
+\entree{"chown", "fchown"}{not implemented (make no sense on a DOS
+file system)}
+\entree{"umask"}{not implemented}
+\entree{"mkfifo"}{not implemented}
+\entree{"kill"}{partially implemented (since 4.00.0): only the "sigkill" signal
+is implemented}
+\entree{"pause"}{not implemented (no inter-process signals in Windows)}
+\entree{"alarm"}{not implemented}
+\entree{"times"}{partially implemented, will not report timings for child
+processes}
+\entree{"getitimer", "setitimer"}{not implemented}
+\entree{"getuid", "geteuid", "getgid", "getegid"}{always return 1}
+\entree{"getgroups"}{always returns "[|1|]" (since 2.00)}
+\entree{"setuid", "setgid", "setgroups"}{not implemented}
+\entree{"getpwnam", "getpwuid"}{always raise "Not_found"}
+\entree{"getgrnam", "getgrgid"}{always raise "Not_found"}
+\entree{type "socket_domain"}{"PF_INET" is fully supported;
+"PF_INET6" is fully supported (since 4.01.0); "PF_UNIX" is not supported }
+\entree{"establish_server"}{not implemented; use threads}
+\entree{terminal functions ("tc*")}{not implemented}
+\end{tableau}
+
+\end{windows}
--- /dev/null
+\chapter{The standard library} \label{c:stdlib}\cutname{stdlib.html}
+\pdfchapterfold{-32}{The standard library}
+
+This chapter describes the functions provided by the OCaml
+standard library. The modules from the standard library are
+automatically linked with the user's object code files by the "ocamlc"
+command. Hence, these modules can be used in standalone programs without
+having to add any ".cmo" file on the command line for the linking
+phase. Similarly, in interactive use, these globals can be used in
+toplevel phrases without having to load any ".cmo" file in memory.
+
+Unlike the "Pervasives" module from the core library, the modules from the
+standard library are not automatically ``opened'' when a compilation
+starts, or when the toplevel system is launched. Hence it is necessary
+to use qualified identifiers to refer to the functions provided by these
+modules, or to add "open" directives.
+
+\label{stdlib:top}
+
+\section*{Conventions}
+
+For easy reference, the modules are listed below in alphabetical order
+of module names.
+For each module, the declarations from its signature are printed
+one by one in typewriter font, followed by a short comment.
+All modules and the identifiers they export are indexed at the end of
+this report.
+
+\begin{latexonly}
+\section*{Overview}
+
+Here is a short listing, by theme, of the standard library modules.
+
+\subsubsection*{Data structures:}
+\begin{tabular}{lll}
+% Beware: these entries must be written in a very rigidly-defined
+% format, or the check-stdlib-modules script will complain.
+"String" & p.~\pageref{String} & string operations \\
+"Bytes" & p.~\pageref{Bytes} & operations on byte sequences\\
+"Array" & p.~\pageref{Array} & array operations \\
+"List" & p.~\pageref{List} & list operations \\
+"StdLabels" & p.~\pageref{StdLabels} & labelized versions of
+the above 4 modules \\
+"Char" & p.~\pageref{Char} & character operations \\
+"Uchar" & p.~\pageref{Uchar} & Unicode characters \\
+"Sort" & p.~\pageref{Sort} & (deprecated) \\
+"Hashtbl" & p.~\pageref{Hashtbl} & hash tables and hash functions \\
+"Random" & p.~\pageref{Random} & pseudo-random number generator \\
+"Set" & p.~\pageref{Set} & sets over ordered types \\
+"Map" & p.~\pageref{Map} & association tables over ordered types \\
+"MoreLabels" & p.~\pageref{MoreLabels} & labelized versions of
+"Hashtbl", "Set", and "Map" \\
+"Oo" & p.~\pageref{Oo} & useful functions on objects \\
+"Stack" & p.~\pageref{Stack} & last-in first-out stacks \\
+"Queue" & p.~\pageref{Queue} & first-in first-out queues \\
+"Buffer" & p.~\pageref{Buffer} & buffers that grow on demand \\
+"Seq" & p.~\pageref{Seq} & functional iterators \\
+"Lazy" & p.~\pageref{Lazy} & delayed evaluation \\
+"Weak" & p.~\pageref{Weak} & references that don't prevent objects
+from being garbage-collected \\
+"Ephemeron" & p.~\pageref{Ephemeron} & ephemerons and weak hash tables \\
+"Bigarray" & p.~\pageref{Bigarray} & large, multi-dimensional, numerical arrays
+\end{tabular}
+\subsubsection*{Arithmetic:}
+\begin{tabular}{lll}
+"Complex" & p.~\pageref{Complex} & Complex numbers \\
+"Float" & p.~\pageref{Float} & Floating-point numbers \\
+"Int32" & p.~\pageref{Int32} & operations on 32-bit integers \\
+"Int64" & p.~\pageref{Int64} & operations on 64-bit integers \\
+"Nativeint" & p.~\pageref{Nativeint} & operations on platform-native
+integers
+\end{tabular}
+\subsubsection{Input/output:}
+\begin{tabular}{lll}
+"Format" & p.~\pageref{Format} & pretty printing with automatic
+indentation and line breaking \\
+"Marshal" & p.~\pageref{Marshal} & marshaling of data structures \\
+"Printf" & p.~\pageref{Printf} & formatting printing functions \\
+"Scanf" & p.~\pageref{Scanf} & formatted input functions \\
+"Digest" & p.~\pageref{Digest} & MD5 message digest \\
+\end{tabular}
+\subsubsection{Parsing:}
+\begin{tabular}{lll}
+"Genlex" & p.~\pageref{Genlex} & a generic lexer over streams \\
+"Lexing" & p.~\pageref{Lexing} & the run-time library for lexers generated by "ocamllex" \\
+"Parsing" & p.~\pageref{Parsing} & the run-time library for parsers generated by "ocamlyacc" \\
+"Stream" & p.~\pageref{Stream} & basic functions over streams \\
+\end{tabular}
+\subsubsection{System interface:}
+\begin{tabular}{lll}
+"Arg" & p.~\pageref{Arg} & parsing of command line arguments \\
+"Callback" & p.~\pageref{Callback} & registering OCaml functions to
+be called from C \\
+"Filename" & p.~\pageref{Filename} & operations on file names \\
+"Gc" & p.~\pageref{Gc} & memory management control and statistics \\
+"Printexc" & p.~\pageref{Printexc} & a catch-all exception handler \\
+"Spacetime" & p.~\pageref{Spacetime} & memory profiler \\
+"Sys" & p.~\pageref{Sys} & system interface \\
+\end{tabular}
+\end{latexonly}
+
+\ifouthtml
+\begin{links}
+\item \ahref{libref/Arg.html}{Module \texttt{Arg}: parsing of command line arguments}
+\item \ahref{libref/Array.html}{Module \texttt{Array}: array operations}
+\item \ahref{libref/ArrayLabels.html}{Module \texttt{ArrayLabels}: array operations (with labels)}
+\item \ahref{libref/Bigarray.html}{Module \texttt{Bigarray}: large, multi-dimensional, numerical arrays}
+\item \ahref{libref/Buffer.html}{Module \texttt{Buffer}: extensible buffers}
+\item \ahref{libref/Bytes.html}{Module \texttt{Bytes}: byte sequences}
+\item \ahref{libref/BytesLabels.html}{Module \texttt{BytesLabels}: byte sequences (with labels)}
+\item \ahref{libref/Callback.html}{Module \texttt{Callback}: registering OCaml values with the C runtime}
+\item \ahref{libref/Char.html}{Module \texttt{Char}: character operations}
+\item \ahref{libref/Complex.html}{Module \texttt{Complex}: Complex numbers}
+\item \ahref{libref/Digest.html}{Module \texttt{Digest}: MD5 message digest}
+\item \ahref{libref/Ephemeron.html}{Module \texttt{Ephemeron}: Ephemerons and weak hash table}
+\item \ahref{libref/Filename.html}{Module \texttt{Filename}: operations on file names}
+\item \ahref{libref/Float.html}{Module \texttt{Float}: Floating-point numbers}
+\item \ahref{libref/Format.html}{Module \texttt{Format}: pretty printing}
+\item \ahref{libref/Gc.html}{Module \texttt{Gc}: memory management control and statistics; finalized values}
+\item \ahref{libref/Genlex.html}{Module \texttt{Genlex}: a generic lexical analyzer}
+\item \ahref{libref/Hashtbl.html}{Module \texttt{Hashtbl}: hash tables and hash functions}
+\item \ahref{libref/Int32.html}{Module \texttt{Int32}: 32-bit integers}
+\item \ahref{libref/Int64.html}{Module \texttt{Int64}: 64-bit integers}
+\item \ahref{libref/Lazy.html}{Module \texttt{Lazy}: deferred computations}
+\item \ahref{libref/Lexing.html}{Module \texttt{Lexing}: the run-time library for lexers generated by \texttt{ocamllex}}
+\item \ahref{libref/List.html}{Module \texttt{List}: list operations}
+\item \ahref{libref/ListLabels.html}{Module \texttt{ListLabels}: list operations (with labels)}
+\item \ahref{libref/Map.html}{Module \texttt{Map}: association tables over ordered types}
+\item \ahref{libref/Marshal.html}{Module \texttt{Marshal}: marshaling of data structures}
+\item \ahref{libref/MoreLabels.html}{Module \texttt{MoreLabels}: Include modules \texttt{Hashtbl}, \texttt{Map} and \texttt{Set} with labels}
+\item \ahref{libref/Nativeint.html}{Module \texttt{Nativeint}: processor-native integers}
+\item \ahref{libref/Oo.html}{Module \texttt{Oo}: object-oriented extension}
+\item \ahref{libref/Parsing.html}{Module \texttt{Parsing}: the run-time library for parsers generated by \texttt{ocamlyacc}}
+\item \ahref{libref/Printexc.html}{Module \texttt{Printexc}: facilities for printing exceptions}
+\item \ahref{libref/Printf.html}{Module \texttt{Printf}: formatting printing functions}
+\item \ahref{libref/Queue.html}{Module \texttt{Queue}: first-in first-out queues}
+\item \ahref{libref/Random.html}{Module \texttt{Random}: pseudo-random number generator (PRNG)}
+\item \ahref{libref/Scanf.html}{Module \texttt{Scanf}: formatted input functions}
+\item \ahref{libref/Seq.html}{Module \texttt{Seq}: functional iterators}
+\item \ahref{libref/Set.html}{Module \texttt{Set}: sets over ordered types}
+\item \ahref{libref/Sort.html}{Module \texttt{Sort}: deprecated}
+\item \ahref{libref/Spacetime.html}{Module \texttt{Spacetime}: memory profiler}
+\item \ahref{libref/Stack.html}{Module \texttt{Stack}: last-in first-out stacks}
+\item \ahref{libref/StdLabels.html}{Module \texttt{StdLabels}: Include modules \texttt{Array}, \texttt{List} and \texttt{String} with labels}
+\item \ahref{libref/Stream.html}{Module \texttt{Stream}: streams and parsers}
+\item \ahref{libref/String.html}{Module \texttt{String}: string operations}
+\item \ahref{libref/StringLabels.html}{Module \texttt{StringLabels}: string operations (with labels)}
+\item \ahref{libref/Sys.html}{Module \texttt{Sys}: system interface}
+\item \ahref{libref/Uchar.html}{Module \texttt{Uchar}: Unicode characters}
+\item \ahref{libref/Weak.html}{Module \texttt{Weak}: arrays of weak pointers}
+\end{links}
+\else
+\input{Arg.tex}
+\input{Array.tex}
+\input{ArrayLabels.tex}
+\input{Bigarray.tex}
+\input{Buffer.tex}
+\input{Bytes.tex}
+\input{BytesLabels.tex}
+\input{Callback.tex}
+\input{Char.tex}
+\input{Complex.tex}
+\input{Digest.tex}
+\input{Ephemeron.tex}
+\input{Filename.tex}
+\input{Float.tex}
+\input{Format.tex}
+\input{Gc.tex}
+\input{Genlex.tex}
+\input{Hashtbl.tex}
+\input{Int32.tex}
+\input{Int64.tex}
+\input{Lazy.tex}
+\input{Lexing.tex}
+\input{List.tex}
+\input{ListLabels.tex}
+\input{Map.tex}
+\input{Marshal.tex}
+\input{MoreLabels.tex}
+\input{Nativeint.tex}
+\input{Oo.tex}
+\input{Parsing.tex}
+\input{Printexc.tex}
+\input{Printf.tex}
+\input{Queue.tex}
+\input{Random.tex}
+\input{Scanf.tex}
+\input{Seq.tex}
+\input{Set.tex}
+\input{Sort.tex}
+\input{Spacetime.tex}
+\input{Stack.tex}
+\input{StdLabels.tex}
+\input{Stream.tex}
+\input{String.tex}
+\input{StringLabels.tex}
+\input{Sys.tex}
+\input{Uchar.tex}
+\input{Weak.tex}
+\fi
--- /dev/null
+% Colors for links
+\def\visited@color{\#0d46a3}
+\def\link@color{\#4286f4}
+\def\hover@color{\@getstylecolor{subsection}}
+\newstyle{a:link}{color:\link@color;text-decoration:underline;}
+\newstyle{a:visited}{color:\visited@color;text-decoration:underline;}
+\newstyle{a:hover}{color:black;text-decoration:underline;background-color:\hover@color}
+
+
+\newstyle{@media all}{@font-face \{
+/* fira-sans-regular - latin */
+ font-family: 'Fira Sans';
+ font-style: normal;
+ font-weight: 400;
+ src: url('/pub/docs/manual-ocaml/fonts/fira-sans-v8-latin-regular.eot'); /* IE9 Compat Modes */
+ src: local('Fira Sans Regular'), local('FiraSans-Regular'),
+ url('/pub/docs/manual-ocaml/fonts/fira-sans-v8-latin-regular.eot?\#iefix') format('embedded-opentype'), /* IE6-IE8 */
+ url('/pub/docs/manual-ocaml/fonts/fira-sans-v8-latin-regular.woff2') format('woff2'), /* Super Modern Browsers */
+ url('/pub/docs/manual-ocaml/fonts/fira-sans-v8-latin-regular.woff') format('woff'), /* Modern Browsers */
+ url('/pub/docs/manual-ocaml/fonts/fira-sans-v8-latin-regular.ttf') format('truetype'), /* Safari, Android, iOS */
+ url('/pub/docs/manual-ocaml/fonts/fira-sans-v8-latin-regular.svg\#FiraSans') format('svg'); /* Legacy iOS */
+\}}
+
+% Compact layout
+\newstyle{body}{
+ max-width:750px;
+ width: 85\%;
+ margin: auto;
+ background: \#f7f7f7;
+ margin-top: 80px;
+ font-size: 1rem;
+}
+
+% selects the index's title
+\newstyle{.maintitle}{
+ font-family: "Fira Sans", sans-serif;
+ text-align: center;
+}
+
+\newstyle{h1, h2, h3}{
+ font-family: "Fira Sans", sans-serif;
+ font-weight: normal;
+ border-bottom: 1px solid black;
+}
+
+\newstyle{pre}{
+ font-size: 1rem;
+ background: beige;
+ border: 1px solid grey;
+ padding: 10px;
+ overflow-y:auto;
+ white-space: pre-wrap;
+}
+
+% More spacing between lines and inside tables
+\newstyle{p,ul}{line-height:1.3em}
+\newstyle{.cellpadding1 tr td}{padding:1px 4px}
+
+%Styles for caml-example and friends
+\newstyle{div.caml-output}{color:maroon;}
+\newstyle{div.caml-example pre}{margin:2ex 0px;}
+% Styles for toplevel mode only
+\newstyle{div.caml-example.toplevel div.caml-input::before}
+ {content:"\#"; color:black;}
+\newstyle{div.caml-example.toplevel div.caml-input}{color:\#006000;}
+%%%
+\newcommand{\input@color}{\htmlcolor{006000}}
+\newcommand{\output@color}{\maroon}
+\newcommand{\machine}{\tt}
+\newenvironment{machineenv}{\begin{alltt}}{\end{alltt}}
+\newcommand{\firstline}{\ }
+\newcommand{\examplespace}{\ }
+\newcommand{\nextline}{\examplespace\ }
+\newcommand{\@zyva}{\firstline\renewcommand{\?}{\nextline}}
+\let\?=\@zyva
+\newenvironment{camlunder}{\@style{U}}{}
+\newcommand{\caml}{\begin{alltt}\renewcommand{\;}{}\renewcommand{\\}{\char92}\def\<{\begin{camlunder}}\def\>{\end{camlunder}}\activebracefalse}
+\newcommand{\endcaml}{\activebracetrue\end{alltt}
+}
+\renewcommand{\:}{\renewcommand{\?}{\@zyva}}
+\newcommand{\var}[1]{\textit{#1}}
+
+% Caml-example environment
+\newcommand{\camlexample}[1]{
+ \ifthenelse{\equal{#1}{toplevel}}
+ {\renewcommand{\examplespace}{\ }}
+ {\renewcommand{\examplespace}{}}
+ \fi
+ \@open{div}{class="caml-example #1"}
+}
+\newcommand{\endcamlexample}{
+ \@close{div}
+ \renewcommand{\examplespace}{\ }
+}
+
+\newcommand{\camlinput}{\@open{div}{class="caml-input"}}
+\newcommand{\endcamlinput}{\@close{div}}
+\newcommand{\camloutput}{\@open{div}{class="caml-output ok"}}
+\newcommand{\endcamloutput}{\@close{div}}
+\newcommand{\camlerror}{\@open{div}{class="caml-output error"}}
+\newcommand{\endcamlerror}{\@close{div}}
+\newcommand{\camlwarn}{\@open{div}{class="caml-output warn"}}
+\newcommand{\endcamlwarn}{\@close{div}}
+
+\newenvironment{library}{}{}
+\newcounter{page}
+\newenvironment{comment}{\begin{quote}}{\end{quote}}
+\newcommand{\nth}[2]{\({#1}_{#2}\)}
+\newenvironment{options}{\begin{description}}{\end{description}}
+
+
+%%venant de macros.tex
+
+\def\versionspecific#1{\begin{quote}\textsf{#1:}\quad}
+\def\unix{\versionspecific{Unix}}
+\def\endunix{\end{quote}}
+\def\macos{\versionspecific{MacOS~9}}
+\def\endmacos{\end{quote}}
+\def\windows{\versionspecific{Windows}}
+\def\endwindows{\end{quote}}
+
+\def\requirements{\trivlist \item[\hskip\labelsep {\bf Requirements.}]}
+\def\endrequirements{\endtrivlist}
+\def\installation{\trivlist \item[\hskip\labelsep {\bf Installation.}]}
+\def\endinstallation{\endtrivlist}
+\def\troubleshooting{\trivlist \item[\hskip\labelsep {\bf Troubleshooting.}]}
+\def\endtroubleshooting{\endtrivlist}
+
+\newtheorem{gcrule}{Rule}
+
+% Pour les tables de priorites et autres tableaux a deux colonnes, encadres
+
+\def\entree#1#2{#1 & #2 \\}
+\def\tableau#1#2#3{%
+\par
+\@open{div}{class="tableau"}
+\begin{center}%
+\begin{tabular*}{.8\linewidth}{#1}%
+\multicolumn{1}{c}{\textbf{#2}} &
+\multicolumn{1}{c}{\textbf{#3}} \\
+%%#2 & #3 \\%
+}%
+\def\endtableau{\end{tabular*}\end{center}\@close{div}\par}
+
+\newstyle{.tableau, .syntax, .syntaxleft}{
+ /* same width as body */
+ max-width: 750px;
+ overflow-y: auto;
+}
+
+% L'environnement library (pour composer les descriptions des modules
+% de bibliotheque).
+
+
+\def\restoreindent{\begingroup\let\@listI=\@savedlistI}
+\def\endrestoreindent{\endgroup}
+
+
+% PDF stuff
+
+\def\pdfchapterfold#1#2{}
+\def\pdfsection#1{}
+\def\pdfchapter{\pdfchapterfold{0}}
+
+%%% Pour camlidl
+
+\def\transl#1{$[\![\mbox{#1}]\!]$}
+
+% Pour l'index
+\usepackage{multind}
+\let\indexentry=\index
+\renewcommand{\index}[1]{\indexentry{\jobname}{#1}}
+\def\ikwd#1{\indexentry{\jobname.kwd}{#1}}
+% nth
+
+\def\th{^{\mbox{\scriptsize th}}}
+\renewcommand{\hbox}[1]{\mbox{#1}}
+
+% Notations pour les metavariables
+\def\nmth#1#2#3{\({#1}_{#2}^{#3}\)}
+\def\optvar#1{[\var{#1}\/]}
+\def\event{§§}
+\def\fromoneto#1#2{$#1 = 1,\ldots{} , #2$}
+
+\newcommand{\vfill}{}
+\def\number{}
+\def\year{2013}
+
+% Pour alltt
+\def\rminalltt#1{{\rm #1}}
+\def\goodbreak{\ \\}
+\def\@savedlistI{}
+
+%List of links with no space around items
+\newstyle{.li-links}{margin:0ex 0ex;}
+\newenvironment{links}
+{\setenvclass{itemize}{ftoc2}\setenvclass{li-itemize}{li-links}\itemize}
+{\enditemize}
+
+\newenvironment{maintitle}{\@open{div}{class="maintitle"}}{\@close{div}}
--- /dev/null
+\makeatletter
+% Pour hevea
+\newif\ifouthtml\outhtmlfalse
+\newcommand{\cutname}[1]{}
+% Notations pour les metavariables
+\def\var#1{{\it#1}}
+\def\nth#1#2{${\it#1}_{#2}$}
+\def\nmth#1#2#3{${\it#1}_{#2}^{#3}$}
+\def\optvar#1{\textrm{[}\var{#1}\/\textrm{]}}
+\def\event{$\bowtie$}
+\def\fromoneto#1#2{$#1 = 1, \ldots, #2$}
+
+% Pour avoir les exposants sur la ligne au-dessus (???)
+
+\ifplaintext
+\fontdimen14\tensy=12pt
+\fi
+
+% Numerotation
+\setcounter{secnumdepth}{2} % Pour numeroter les \subsection
+\setcounter{tocdepth}{1} % Pour ne pas mettre les \subsection
+ % dans la table des matieres
+
+% Pour avoir "_" qui marche en mode math et en mode normal
+\catcode`\_=13
+\catcode`\\ 2=8
+\def\_{\hbox{\tt\char95}}
+\def_{\ifmmode\ 2\else\_\fi}
+
+\ifplaintext
+\def\ttstretch{\tt}
+\else
+\def\ttstretch{\tt\spaceskip=5.77pt plus 1.83pt minus 1.22pt}
+% La fonte cmr10 a normalement des espaces de 5.25pt non extensibles.
+% En 11 pt ca fait 5.77 pt. On lui ajoute la meme flexibilite que
+% cmr10 agrandie a 11 pt.
+\fi
+
+% Pour la traduction "xxxx" -> {\machine{xxxx}} faite par texquote2
+\def\machine#1{\mbox{\ttstretch{#1}}}
+
+% Pour la traduction "\begin{verbatim}...\end{verbatim}"
+% -> "\begin{machineenv}...\end{machineenv}"
+% faite aussi par texquote2.
+\newenvironment{machineenv}{\alltt}{\endalltt}
+
+% Environnements
+
+\newlength{\versionwidth}
+\setbox0=\hbox{\bf Windows:} \setlength{\versionwidth}{\wd0}
+
+\def\versionspecific#1{
+ \begin{description}\item[#1:]~\\}
+
+\def\unix{\versionspecific{Unix}}
+\def\endunix{\end{description}}
+%\def\macos{\versionspecific{MacOS 9}}
+%\def\endmacos{\end{description}}
+\def\windows{\versionspecific{Windows}}
+\def\endwindows{\end{description}}
+
+\def\requirements{\trivlist \item[\hskip\labelsep {\bf Requirements.}]}
+\def\endrequirements{\endtrivlist}
+\def\installation{\trivlist \item[\hskip\labelsep {\bf Installation.}]}
+\def\endinstallation{\endtrivlist}
+\def\troubleshooting{\trivlist \item[\hskip\labelsep {\bf Troubleshooting.}]}
+\def\endtroubleshooting{\endtrivlist}
+
+\newtheorem{gcrule}{Rule}
+
+% Pour les tables de priorites et autres tableaux a deux colonnes, encadres
+
+\def\tableau#1#2#3{%
+\begin{center}
+\begin{tabular}{#1}
+\hline
+#2 & #3 \\
+\hline
+}
+\def\endtableau{\hline\end{tabular}\end{center}}
+\def\entree#1#2{#1 & #2 \\}
+
+% L'environnement option
+
+\def\optionitem[#1]{\if@noparitem \@donoparitem
+ \else \if@inlabel \indent \par \fi
+ \ifhmode \unskip\unskip \par \fi
+ \if@newlist \if@nobreak \@nbitem \else
+ \addpenalty\@beginparpenalty
+ \addvspace\@topsep \addvspace{-\parskip}\fi
+ \else \addpenalty\@itempenalty \addvspace\itemsep
+ \fi
+ \global\@inlabeltrue
+\fi
+\everypar{\global\@minipagefalse\global\@newlistfalse
+ \if@inlabel\global\@inlabelfalse \hskip -\parindent \box\@labels
+ \penalty\z@ \fi
+ \everypar{}}\global\@nobreakfalse
+\if@noitemarg \@noitemargfalse \if@nmbrlist \refstepcounter{\@listctr}\fi \fi
+\setbox\@tempboxa\hbox{\makelabel{#1}}%
+\global\setbox\@labels
+\ifdim \wd\@tempboxa >\labelwidth
+ \hbox{\unhbox\@labels
+ \hskip -\leftmargin
+ \box\@tempboxa}\hfil\break
+ \else
+ \hbox{\unhbox\@labels
+ \hskip -\leftmargin
+ \hbox to\leftmargin {\makelabel{#1}\hfil}}
+ \fi
+ \ignorespaces}
+
+\def\optionlabel#1{\bf #1}
+\def\options{\list{}{\let\makelabel\optionlabel\let\@item\optionitem}}
+\def\endoptions{\endlist}
+
+% L'environnement library (pour composer les descriptions des modules
+% de bibliotheque).
+
+\def\comment{\penalty200\list{}{}\item[]}
+\def\endcomment{\endlist\penalty-100}
+
+\def\library{
+\begingroup
+\raggedright
+\let\@savedlistI=\@listI%
+\def\@listI{\leftmargin\leftmargini\parsep 0pt plus 1pt\topsep 0pt plus 2pt}%
+\itemsep 0pt
+\topsep 0pt plus 2pt
+\partopsep 0pt
+}
+
+\def\endlibrary{
+\endgroup
+}
+
+\def\restoreindent{\begingroup\let\@listI=\@savedlistI}
+\def\endrestoreindent{\endgroup}
+
+% ^^A...^^A: compose l'interieur en \tt, comme \verb
+
+\catcode`\^^A=\active
+\def\ 1{%
+\begingroup\catcode``=13\@noligs\ttstretch\let\do\@makeother\dospecials%
+\def\@xobeysp{\leavevmode\penalty100\ }%
+\@vobeyspaces\frenchspacing\catcode`\^^A=\active\def\ 1{\endgroup}}
+
+% Pour l'index
+
+\let\indexentry=\index
+\def\index{\indexentry{\jobname}}
+\def\ikwd{\indexentry{\jobname.kwd}}
+
+% Les en-tetes personnalises
+
+\pagestyle{myheadings}
+\def\partmark#1{\markboth{Part \thepart. \ #1}{}}
+\def\chaptermark#1{\markright{Chapter \thechapter. \ #1}}
+
+% nth
+
+\def\th{^{\hbox{\scriptsize th}}}
+
+% Pour annuler l'espacement vertical qui suit un "verbatim"
+\def\cancelverbatim{\vspace{-\topsep}\vspace{-\parskip}}% exact.
+
+% Pour annuler l'espacement vertical entre deux \item consecutifs dans \options
+\def\cancelitemspace{\vspace{-8mm}}% determine empiriquement
+
+% Pour faire la cesure apres _ dans les identificateurs
+\def\={\discretionary{}{}{}}
+\def\cuthere{\discretionary{}{}{}}
+
+% Pour la coupure en petits documents
+
+\let\mysection=\section
+
+%%% Augmenter l'espace entre numero de section
+% et nom de section dans la table des matieres.
+
+\ifplaintext\else
+\def\l@section{\@dottedtocline{1}{1.5em}{2.8em}} % D'origine: 2.3
+\fi
+
+% Pour alltt
+
+\def\rminalltt#1{{\rm #1}}
+
+% redefinition de l'environnement alltt pour que les {} \ et % soient
+% dans la bonne fonte
+
+\let\@oldalltt=\alltt
+\let\@oldendalltt=\endalltt
+\renewenvironment{alltt}{%
+\begingroup%
+\renewcommand{\{}{\char`\{}%
+\renewcommand{\}}{\char`\}}%
+\renewcommand{\\}{\char`\\}%
+\renewcommand{\%}{\char`\%}%
+\@oldalltt%
+}{%
+\@oldendalltt%
+\endgroup%
+}
+
+% Index stuff -- cf multind.sty
+
+\def\printindex#1#2{\@restonecoltrue\if@twocolumn\@restonecolfalse\fi
+ \columnseprule \z@ \columnsep 35pt
+ \newpage \phantomsection \twocolumn[{\Large\bf #2 \vskip4ex}]
+ \markright{\uppercase{#2}}
+ \addcontentsline{toc}{chapter}{#2}
+ \pdfsection{#2}
+ \@input{#1.ind}}
+
+% PDF stuff -- no longer needed, Hyperref does the job
+
+\def\pdfchapterfold#1#2{}
+\def\pdfchapter#1{}
+\def\pdfsection#1{}
+
+%\ifpdf
+%\newcount\pdflabel
+%\pdflabel=1
+%\def\pdfchapterfold#1#2{
+%\pdfdest num \pdflabel fit
+%\pdfoutline goto num \pdflabel count #1 {\arabic{chapter}. #2}
+%\global\advance\pdflabel by 1
+%}
+%\def\pdfsection#1{
+%\pdfdest num \pdflabel fit
+%\pdfoutline goto num \pdflabel {#1}
+%\global\advance\pdflabel by 1
+%}
+%\else
+%\def\pdfchapterfold#1#2{}
+%\def\pdfsection#1{}
+%\fi
+%
+%\def\pdfchapter{\pdfchapterfold{0}}
+
+%%% Pour camlidl
+
+\def\transl#1{$[\![\mbox{#1}]\!]$}
+
+%%% Pour les references des modules
+\newcommand{\moduleref}[1]{\ref{#1}}
+%%% Fin des hacks
+
+\newenvironment{maintitle}{\begin{center}}{\end{center}}
+
+\makeatother
--- /dev/null
+\input{book.hva}
+\input{macros.hva}
+\newif\ifouthtml\outhtmltrue
--- /dev/null
+\input{book.hva}
+\renewcommand{\@indexsection}[1]{\chapter{#1}}
+\newcommand{\black}{\htmlcolor{#000000}}
+\newcommand{\machine}{\tt}
+\newenvironment{machineenv}{\begin{alltt}}{\end{alltt}}
+\newenvironment{camlunder}{\@style{U}}{}
+\newcommand{\caml}{\begin{alltt}\renewcommand{\\}{\char92}\def\<{\begin{camlunder}}\def\>{\end{camlunder}}\activebracefalse}
+\newcommand{\endcaml}{\activebracetrue\end{alltt}}
+\newcommand{\?}{\black\#\blue }
+\renewcommand{\:}{\maroon}
+\def\camlinput{}
+\def\endcamlinput{}
+\def\camloutput{}
+\def\endcamloutput{}
+\def\camlerror{}
+\def\endcamlerror{}
+\def\camlwarn{}
+\def\endcamlwarn{}
+\newcommand{\var}[1]{\textit{#1}}
+
+\newenvironment{library}{}{}
+\newcounter{page}
+\newenvironment{comment}{\begin{quote}}{\end{quote}}
+\newcommand{\nth}[2]{\({#1}_{#2}\)}
+\newenvironment{options}{\begin{description}}{\end{description}}
+
+
+%%venant de macros.tex
+\newif\ifouthtml\outhtmlfalse
+\def\versionspecific#1{
+\quad\textsf{#1:}
+\begin{quote}}
+
+\def\unix{\versionspecific{Unix}}
+\def\endunix{\end{quote}}
+\def\macos{\versionspecific{MacOS}}
+\def\endmacos{\end{quote}}
+\def\windows{\versionspecific{Windows}}
+\def\endwindows{\end{quote}}
+
+\def\requirements{\trivlist \item[\hskip\labelsep {\bf Requirements.}]}
+\def\endrequirements{\endtrivlist}
+\def\installation{\trivlist \item[\hskip\labelsep {\bf Installation.}]}
+\def\endinstallation{\endtrivlist}
+\def\troubleshooting{\trivlist \item[\hskip\labelsep {\bf Troubleshooting.}]}
+\def\endtroubleshooting{\endtrivlist}
+
+\newtheorem{gcrule}{Rule}
+
+% Pour les tables de priorites et autres tableaux a deux colonnes, encadres
+
+%\def\entree#1#2{#1 & #2 \\}
+%\def\tableau#1#2#3{%
+%\par\begin{center}%
+%\begin{tabular}{#1}%
+%\multicolumn{1}{c}{\textbf{#2}} &
+%\multicolumn{1}{c}{\textbf{#3}} \\
+%%#2 & #3 \\%
+%}%
+%\def\endtableau{\end{tabular}\end{center}\par}
+
+% Pour les tables de priorites et autres tableaux a deux colonnes, encadres
+
+\def\tableau#1#2#3{%
+\begin{center}
+\begin{tabular}{#1}
+\hline
+\multicolumn{1}{|c|}{\textbf{#2}} & \multicolumn{1}{c|}{\textbf{#3}} \\
+\hline
+}
+\def\endtableau{\hline\end{tabular}\end{center}}
+\def\entree#1#2{#1 & #2 \\}
+
+
+
+% L'environnement library (pour composer les descriptions des modules
+% de bibliotheque).
+
+
+\def\restoreindent{\begingroup\let\@listI=\@savedlistI}
+\def\endrestoreindent{\endgroup}
+
+
+% PDF stuff
+
+\def\pdfchapterfold#1#2{}
+\def\pdfsection#1{}
+\def\pdfchapter{\pdfchapterfold{0}}
+
+%%% Pour camlidl
+
+\def\transl#1{$[\![\mbox{#1}]\!]$}
+
+% Pour l'index
+\usepackage{multind}
+\let\indexentry=\index
+\renewcommand{\index}[1]{\indexentry{\jobname}{#1}}
+\def\ikwd#1{\indexentry{\jobname.kwd}{#1}}
+
+
+% nth
+\def\th{^{\mbox{\scriptsize th}}}
+\renewcommand{\hbox}[1]{\mbox{#1}}
+
+% Notations pour les metavariables
+\def\nmth#1#2#3{\({#1}_{#2}^{#3}\)}
+\def\optvar#1{[\var{#1}\/]}
+\def\event{§§}
+\def\fromoneto#1#2{$#1 = 1,\ldots{} , #2$}
+
+\newcommand{\vfill}{}
+\def\number{}
+\def\year{2013}
+
+% Pour alltt
+
+\def\rminalltt#1{{\rm #1}}
+
+\def\goodbreak{\ \\}
+
+\def\@savedlistI{}
--- /dev/null
+INFO-DIR-SECTION OCaml Programming Language
+START-INFO-DIR-ENTRY
+* ocaml: (ocaml). OCaml Reference Manual
+END-INFO-DIR-ENTRY
--- /dev/null
+\documentclass[11pt]{book}
+\usepackage[latin1]{inputenc}
+%HEVEA\@def@charset{US-ASCII}%
+\usepackage{alltt}
+\usepackage{fullpage}
+\usepackage{syntaxdef}
+\usepackage{multind}
+\usepackage{html}
+\usepackage{textcomp}
+\usepackage{caml-sl}
+\usepackage{ocamldoc}
+\usepackage{xspace}
+\newif\ifplaintext
+\plaintextfalse
+%\newif\ifpdf
+%\pdffalse
+
+\input{macros.tex}
+
+% Add meta tag to the generated head tag
+\ifouthtml
+\let\oldmeta=\@meta
+\renewcommand{\@meta}{
+\oldmeta
+\begin{rawhtml}
+ <meta name="viewport" content="width=device-width, initial-scale=1.0, maximum-scale=1">
+\end{rawhtml}
+}
+\fi
+
+\usepackage{hyperref}
+%\makeatletter \def\@wrindex#1#2{\xdef \@indexfile{\csname #1@idxfile\endcsname}\@@wrindex#2||\\}\makeatother
+\def\th{^{\hbox{\scriptsize th}}}
+
+\raggedbottom
+\input{version.tex}
+%HEVEA\tocnumber
+%HEVEA\setcounter{cuttingdepth}{1}
+%HEVEA\title{The OCaml system, release \ocamlversion}
+\input{allfiles.tex}
+
+
--- /dev/null
+%\pdfoutput=1
+\pdfpagewidth=21cm
+\pdfpageheight=11in
+\pdfcompresslevel=7
+
+\documentclass[11pt]{book}
+
+\usepackage[latin1]{inputenc}
+\usepackage{alltt}
+\usepackage{fullpage}
+\usepackage{syntaxdef}
+\usepackage{multind}
+\usepackage{html}
+\usepackage{textcomp}
+\usepackage{caml-sl}
+\usepackage{ocamldoc}
+\usepackage{xspace}
+
+\newif\ifplaintext
+\plaintextfalse
+%\newif\ifpdf
+%\pdftrue
+\input macros.tex
+
+\usepackage[colorlinks,linkcolor=blue]{hyperref}
+\def\th{^{\hbox{\scriptsize th}}}
+
+\raggedbottom
+\input{version.tex}
+
+\input allfiles.tex
--- /dev/null
+\documentclass[11pt]{report}
+
+\usepackage{plaintext}
+\usepackage[latin1]{inputenc}
+\usepackage{alltt}
+\usepackage{fullpage}
+\usepackage{syntaxdef}
+\usepackage{multind}
+\usepackage{html}
+\usepackage{caml-sl}
+
+\newif\ifplaintext
+\plaintexttrue
+%\newif\ifpdf
+%\pdffalse
+\input macros.tex
+\input allfiles.tex
--- /dev/null
+*.tex
+*.htex
--- /dev/null
+*.tex
+*.htex
--- /dev/null
+FILES= refman.tex lex.tex names.tex values.tex const.tex types.tex \
+ patterns.tex expr.tex typedecl.tex modtypes.tex modules.tex compunit.tex \
+ exten.tex classes.tex
+
+TOPDIR=../../..
+
+include $(TOPDIR)/Makefile.tools
+
+LD_PATH="$(TOPDIR)/otherlibs/str:$(TOPDIR)/otherlibs/unix"
+
+CAMLLATEX=$(SET_LD_PATH) $(OCAMLRUN) ../../tools/caml-tex2 \
+ -caml "TERM=norepeat $(OCAML)" -n 80 -v false
+TRANSF=$(SET_LD_PATH) $(OCAMLRUN) ../../tools/transf
+TEXQUOTE=../../tools/texquote2
+
+ALLFILES=$(FILES)
+
+etex-files: $(ALLFILES)
+all: $(ALLFILES)
+
+clean:
+ rm -f $(ALLFILES)
+
+.SUFFIXES:
+.SUFFIXES: .etex .tex
+
+exten.tex:exten.etex
+ @$(CAMLLATEX) -o $*.caml_tex_error.tex $*.etex \
+ && mv $*.caml_tex_error.tex $*.gen.tex \
+ && $(TRANSF) < $*.gen.tex > $*.transf_error.tex \
+ && mv $*.transf_error.tex $*.gen.tex\
+ && $(TEXQUOTE) < $*.gen.tex > $*.texquote_error.tex\
+ && mv $*.texquote_error.tex $*.tex\
+ || printf "Failure when generating %s\n" $*.tex
+.etex.tex:
+ @$(TRANSF) < $*.etex > $*.transf_error.tex \
+ && mv $*.transf_error.tex $*.gen.tex\
+ && $(TEXQUOTE) < $*.gen.tex > $*.texquote_error.tex\
+ && mv $*.texquote_error.tex $*.tex\
+ || printf "Failure when generating %s\n" $*.tex
+
+
+$(ALLFILES): ../../tools/transf $(TEXQUOTE)
--- /dev/null
+\section{Classes}
+\pdfsection{Classes}
+%HEVEA\cutname{classes.html}
+Classes are defined using a small language, similar to the module
+language.
+
+\subsection{Class types}
+
+Class types are the class-level equivalent of type expressions: they
+specify the general shape and type properties of classes.
+
+\ikwd{object\@\texttt{object}}
+\ikwd{end\@\texttt{end}}
+\ikwd{inherit\@\texttt{inherit}}
+\ikwd{val\@\texttt{val}}
+\ikwd{mutable\@\texttt{mutable}}
+\ikwd{method\@\texttt{method}}
+\ikwd{private\@\texttt{private}}
+\ikwd{virtual\@\texttt{virtual}|see{\texttt{val}, \texttt{method}, \texttt{class}}}
+\ikwd{constraint\@\texttt{constraint}}
+
+\begin{syntax}
+class-type:
+ [['?']label-name':'] typexpr '->' class-type
+ | class-body-type
+;
+class-body-type:
+ 'object' ['(' typexpr ')'] {class-field-spec} 'end'
+ | ['[' typexpr {',' typexpr} ']'] classtype-path
+ | 'let' 'open' module-path 'in' class-body-type
+;
+%\end{syntax} \begin{syntax}
+class-field-spec:
+ 'inherit' class-body-type
+ | 'val' ['mutable'] ['virtual'] inst-var-name ':' typexpr
+ | 'val' 'virtual' 'mutable' inst-var-name ':' typexpr
+ | 'method' ['private'] ['virtual'] method-name ':' poly-typexpr
+ | 'method' 'virtual' 'private' method-name ':' poly-typexpr
+ | 'constraint' typexpr '=' typexpr
+\end{syntax}
+See also the following language extensions:
+\hyperref[s:attributes]{attributes} and
+\hyperref[s:extension-nodes]{extension nodes}.
+
+\subsubsection*{Simple class expressions}
+
+The expression @classtype-path@ is equivalent to the class type bound to
+the name @classtype-path@. Similarly, the expression
+@'[' typexpr_1 ',' \ldots typexpr_n ']' classtype-path@ is equivalent to
+the parametric class type bound to the name @classtype-path@, in which
+type parameters have been instantiated to respectively @typexpr_1@,
+\ldots @typexpr_n@.
+
+\subsubsection*{Class function type}
+
+The class type expression @typexpr '->' class-type@ is the type of
+class functions (functions from values to classes) that take as
+argument a value of type @typexpr@ and return as result a class of
+type @class-type@.
+
+\subsubsection*{Class body type}
+
+The class type expression
+@'object' ['(' typexpr ')'] {class-field-spec} 'end'@
+is the type of a class body. It specifies its instance variables and
+methods. In this type, @typexpr@ is matched against the self type, therefore
+providing a name for the self type.
+
+A class body will match a class body type if it provides definitions
+for all the components specified in the class body type, and these
+definitions meet the type requirements given in the class body type.
+Furthermore, all methods either virtual or public present in the class
+body must also be present in the class body type (on the other hand, some
+instance variables and concrete private methods may be omitted). A
+virtual method will match a concrete method, which makes it possible
+to forget its implementation. An immutable instance variable will match a
+mutable instance variable.
+
+\subsubsection*{Local opens}
+
+Local opens are supported in class types since OCaml 4.06.
+
+\subsubsection*{Inheritance}
+
+\ikwd{inherit\@\texttt{inherit}}
+
+The inheritance construct @'inherit' class-body-type@ provides for inclusion of
+methods and instance variables from other class types.
+The instance variable and method types from @class-body-type@ are added
+into the current class type.
+
+\subsubsection*{Instance variable specification}
+
+\ikwd{val\@\texttt{val}}
+\ikwd{mutable\@\texttt{mutable}}
+
+A specification of an instance variable is written
+@'val' ['mutable'] ['virtual'] inst-var-name ':' typexpr@, where
+@inst-var-name@
+is the name of the instance variable and @typexpr@ its expected type.
+%
+The flag @'mutable'@ indicates whether this instance variable can be
+physically modified.
+%
+The flag @'virtual'@ indicates that this instance variable is not
+initialized. It can be initialized later through inheritance.
+
+An instance variable specification will hide any previous
+specification of an instance variable of the same name.
+
+\subsubsection*{Method specification}
+\label{sec-methspec}
+
+\ikwd{method\@\texttt{method}}
+\ikwd{private\@\texttt{private}}
+
+The specification of a method is written
+@'method' ['private'] method-name ':' poly-typexpr@, where
+@method-name@ is the name of the method and @poly-typexpr@ its
+expected type, possibly polymorphic. The flag @'private'@ indicates
+that the method cannot be accessed from outside the object.
+
+The polymorphism may be left implicit in public method specifications:
+any type variable which is not bound to a class parameter and does not
+appear elsewhere inside the class specification will be assumed to be
+universal, and made polymorphic in the resulting method type.
+Writing an explicit polymorphic type will disable this behaviour.
+
+If several specifications are present for the same method, they
+must have compatible types.
+Any non-private specification of a method forces it to be public.
+
+\subsubsection*{Virtual method specification}
+
+\ikwd{method\@\texttt{method}}
+\ikwd{private\@\texttt{private}}
+
+A virtual method specification is written @'method' ['private']
+'virtual' method-name ':' poly-typexpr@, where @method-name@ is the
+name of the method and @poly-typexpr@ its expected type.
+
+\subsubsection*{Constraints on type parameters}
+
+\ikwd{constraint\@\texttt{constraint}}
+
+The construct @'constraint' typexpr_1 '=' typexpr_2@ forces the two
+type expressions to be equal. This is typically used to specify type
+parameters: in this way, they can be bound to specific type
+expressions.
+
+\subsection{Class expressions}
+
+Class expressions are the class-level equivalent of value expressions:
+they evaluate to classes, thus providing implementations for the
+specifications expressed in class types.
+
+\ikwd{object\@\texttt{object}}
+\ikwd{end\@\texttt{end}}
+\ikwd{fun\@\texttt{fun}}
+\ikwd{let\@\texttt{let}}
+\ikwd{and\@\texttt{and}}
+\ikwd{inherit\@\texttt{inherit}}
+\ikwd{as\@\texttt{as}}
+\ikwd{val\@\texttt{val}}
+\ikwd{mutable\@\texttt{mutable}}
+\ikwd{method\@\texttt{method}}
+\ikwd{private\@\texttt{private}}
+\ikwd{constraint\@\texttt{constraint}}
+\ikwd{initializer\@\texttt{initializer}}
+
+\begin{syntax}
+class-expr:
+ class-path
+ | '[' typexpr {',' typexpr} ']' class-path
+ | '(' class-expr ')'
+ | '(' class-expr ':' class-type ')'
+ | class-expr {{argument}}
+ | 'fun' {{parameter}} '->' class-expr
+ | 'let' ['rec'] let-binding {'and' let-binding} 'in' class-expr
+ | 'object' class-body 'end'
+ | 'let' 'open' module-path 'in' class-expr
+;
+%BEGIN LATEX
+\end{syntax} \begin{syntax}
+%END LATEX
+class-field:
+ 'inherit' class-expr ['as' lowercase-ident]
+ | 'inherit!' class-expr ['as' lowercase-ident]
+ | 'val' ['mutable'] inst-var-name [':' typexpr] '=' expr
+ | 'val!' ['mutable'] inst-var-name [':' typexpr] '=' expr
+ | 'val' ['mutable'] 'virtual' inst-var-name ':' typexpr
+ | 'val' 'virtual' 'mutable' inst-var-name ':' typexpr
+ | 'method' ['private'] method-name {parameter} [':' typexpr] '=' expr
+ | 'method!' ['private'] method-name {parameter} [':' typexpr] '=' expr
+ | 'method' ['private'] method-name ':' poly-typexpr '=' expr
+ | 'method!' ['private'] method-name ':' poly-typexpr '=' expr
+ | 'method' ['private'] 'virtual' method-name ':' poly-typexpr
+ | 'method' 'virtual' 'private' method-name ':' poly-typexpr
+ | 'constraint' typexpr '=' typexpr
+ | 'initializer' expr
+\end{syntax}
+See also the following language extensions:
+\hyperref[s:locally-abstract]{locally abstract types},
+\hyperref[s:attributes]{attributes} and
+\hyperref[s:extension-nodes]{extension nodes}.
+
+\subsubsection*{Simple class expressions}
+
+The expression @class-path@ evaluates to the class bound to the name
+@class-path@. Similarly, the expression
+@'[' typexpr_1 ',' \ldots typexpr_n ']' class-path@
+evaluates to the parametric class bound to the name @class-path@,
+in which type parameters have been instantiated respectively to
+@typexpr_1@, \ldots @typexpr_n@.
+
+The expression @'(' class-expr ')'@ evaluates to the same module as
+@class-expr@.
+
+The expression @'(' class-expr ':' class-type ')'@ checks that
+@class-type@ matches the type of @class-expr@ (that is, that the
+implementation @class-expr@ meets the type specification
+@class-type@). The whole expression evaluates to the same class as
+@class-expr@, except that all components not specified in
+@class-type@ are hidden and can no longer be accessed.
+
+\subsubsection*{Class application}
+
+Class application is denoted by juxtaposition of (possibly labeled)
+expressions. It denotes the class whose constructor is the first
+expression applied to the given arguments. The arguments are
+evaluated as for expression application, but the constructor itself will
+only be evaluated when objects are created. In particular, side-effects
+caused by the application of the constructor will only occur at object
+creation time.
+
+\subsubsection*{Class function}
+
+The expression @'fun' [['?']label-name':']pattern '->' class-expr@ evaluates
+to a function from values to classes.
+When this function is applied to a value \var{v}, this value is
+matched against the pattern @pattern@ and the result is the result of
+the evaluation of @class-expr@ in the extended environment.
+
+Conversion from functions with default values to functions with
+patterns only works identically for class functions as for normal
+functions.
+
+The expression
+\begin{center}
+@"fun" parameter_1 \ldots parameter_n "->" class-expr@
+\end{center}
+is a short form for
+\begin{center}
+@"fun" parameter_1 "->" \ldots "fun" parameter_n "->" expr@
+\end{center}
+
+\subsubsection*{Local definitions}
+
+The {\tt let} and {\tt let rec} constructs bind value names locally,
+as for the core language expressions.
+
+If a local definition occurs at the very beginning of a class
+definition, it will be evaluated when the class is created (just as if
+the definition was outside of the class).
+Otherwise, it will be evaluated when the object constructor is called.
+
+\subsubsection*{Local opens}
+
+Local opens are supported in class expressions since OCaml 4.06.
+
+\subsubsection*{Class\label{ss:class-body} body}
+\begin{syntax}
+class-body: ['(' pattern [':' typexpr] ')'] { class-field }
+\end{syntax}
+The expression
+@'object' class-body 'end'@ denotes
+a class body. This is the prototype for an object : it lists the
+instance variables and methods of an objet of this class.
+
+A class body is a class value: it is not evaluated at once. Rather,
+its components are evaluated each time an object is created.
+
+In a class body, the pattern @'(' pattern [':' typexpr] ')'@ is
+matched against self, therefore providing a binding for self and self
+type. Self can only be used in method and initializers.
+
+Self type cannot be a closed object type, so that the class remains
+extensible.
+
+Since OCaml 4.01, it is an error if the same method or instance
+variable name is defined several times in the same class body.
+
+\subsubsection*{Inheritance}
+
+\ikwd{inherit\@\texttt{inherit}}
+
+The inheritance construct @'inherit' class-expr@ allows reusing
+methods and instance variables from other classes. The class
+expression @class-expr@ must evaluate to a class body. The instance
+variables, methods and initializers from this class body are added
+into the current class. The addition of a method will override any
+previously defined method of the same name.
+
+\ikwd{as\@\texttt{as}}
+An ancestor can be bound by appending @'as' lowercase-ident@
+to the inheritance construct. @lowercase-ident@ is not a true
+variable and can only be used to select a method, i.e. in an expression
+@lowercase-ident '#' method-name@. This gives access to the
+method @method-name@ as it was defined in the parent class even if it is
+redefined in the current class.
+The scope of this ancestor binding is limited to the current class.
+The ancestor method may be called from a subclass but only indirectly.
+
+\subsubsection*{Instance variable definition}
+
+\ikwd{val\@\texttt{val}}
+\ikwd{mutable\@\texttt{mutable}}
+
+The definition @'val' ['mutable'] inst-var-name '=' expr@ adds an
+instance variable @inst-var-name@ whose initial value is the value of
+expression @expr@.
+%
+The flag @'mutable'@ allows physical modification of this variable by
+methods.
+
+An instance variable can only be used in the methods and
+initializers that follow its definition.
+
+Since version 3.10, redefinitions of a visible instance variable with
+the same name do not create a new variable, but are merged, using the
+last value for initialization. They must have identical types and
+mutability.
+However, if an instance variable is hidden by
+omitting it from an interface, it will be kept distinct from
+other instance variables with the same name.
+
+\subsubsection*{Virtual instance variable definition}
+
+\ikwd{val\@\texttt{val}}
+\ikwd{mutable\@\texttt{mutable}}
+
+A variable specification is written @'val' ['mutable'] 'virtual'
+inst-var-name ':' typexpr@. It specifies whether the variable is
+modifiable, and gives its type.
+
+Virtual instance variables were added in version 3.10.
+
+\subsubsection*{Method definition}
+
+\ikwd{method\@\texttt{method}}
+\ikwd{private\@\texttt{private}}
+
+A method definition is written @'method' method-name '=' expr@. The
+definition of a method overrides any previous definition of this
+method. The method will be public (that is, not private) if any of
+the definition states so.
+
+A private method, @'method' 'private' method-name '=' expr@, is a
+method that can only be invoked on self (from other methods of the
+same object, defined in this class or one of its subclasses). This
+invocation is performed using the expression
+@value-name '#' method-name@, where @value-name@ is directly bound to
+self at the beginning of the class definition. Private methods do
+not appear in object types. A method may have both public and private
+definitions, but as soon as there is a public one, all subsequent
+definitions will be made public.
+
+Methods may have an explicitly polymorphic type, allowing them to be
+used polymorphically in programs (even for the same object). The
+explicit declaration may be done in one of three ways: (1) by giving an
+explicit polymorphic type in the method definition, immediately after
+the method name, {\em i.e.}
+@'method' ['private'] method-name ':' {{"'" ident}} '.' typexpr '='
+expr@; (2) by a forward declaration of the explicit polymorphic type
+through a virtual method definition; (3) by importing such a
+declaration through inheritance and/or constraining the type of {\em
+self}.
+
+Some special expressions are available in method bodies for
+manipulating instance variables and duplicating self:
+\begin{syntax}
+expr:
+ \ldots
+ | inst-var-name '<-' expr
+ | '{<' [ inst-var-name '=' expr { ';' inst-var-name '=' expr } [';'] ] '>}'
+\end{syntax}
+
+The expression @inst-var-name '<-' expr@ modifies in-place the current
+object by replacing the value associated to @inst-var-name@ by the
+value of @expr@. Of course, this instance variable must have been
+declared mutable.
+
+The expression
+@'{<' inst-var-name_1 '=' expr_1 ';' \ldots ';' inst-var-name_n '=' expr_n '>}'@
+evaluates to a copy of the current object in which the values of
+instance variables @inst-var-name_1, \ldots, inst-var-name_n@ have
+been replaced by the values of the corresponding expressions @expr_1,
+\ldots, expr_n@.
+
+\subsubsection*{Virtual method definition}
+
+\ikwd{method\@\texttt{method}}
+\ikwd{private\@\texttt{private}}
+
+A method specification is written @'method' ['private'] 'virtual'
+method-name ':' poly-typexpr@. It specifies whether the method is
+public or private, and gives its type. If the method is intended to be
+polymorphic, the type must be explicitly polymorphic.
+
+\subsubsection*{Explicit overriding}
+
+Since Ocaml 3.12, the keywords @"inherit!"@, @"val!"@ and @"method!"@
+have the same semantics as @"inherit"@, @"val"@ and @"method"@, but
+they additionally require the definition they introduce to be
+overriding. Namely, @"method!"@ requires @method-name@ to be already
+defined in this class, @"val!"@ requires @inst-var-name@ to be already
+defined in this class, and @"inherit!"@ requires @class-expr@ to
+override some definitions. If no such overriding occurs, an error is
+signaled.
+
+As a side-effect, these 3 keywords avoid the warnings~7
+(method override) and~13 (instance variable override).
+Note that warning~7 is disabled by default.
+
+\subsubsection*{Constraints on type parameters}
+
+\ikwd{constraint\@\texttt{constraint}}
+The construct @'constraint' typexpr_1 '=' typexpr_2@ forces the two
+type expressions to be equals. This is typically used to specify type
+parameters: in that way they can be bound to specific type
+expressions.
+
+\subsubsection*{Initializers}
+
+\ikwd{initializer\@\texttt{initializer}}
+
+A class initializer @'initializer' expr@ specifies an expression that
+will be evaluated whenever an object is created from the class, once
+all its instance variables have been initialized.
+
+\subsection{Class definitions}
+\label{s:classdef}
+
+\ikwd{class\@\texttt{class}}
+\ikwd{and\@\texttt{and}}
+
+\begin{syntax}
+class-definition:
+ 'class' class-binding { 'and' class-binding }
+;
+class-binding:
+ ['virtual'] ['[' type-parameters ']'] class-name
+ {parameter} [':' class-type] \\ '=' class-expr
+;
+type-parameters:
+ "'" ident { "," "'" ident }
+\end{syntax}
+
+A class definition @'class' class-binding { 'and' class-binding }@ is
+recursive. Each @class-binding@ defines a @class-name@ that can be
+used in the whole expression except for inheritance. It can also be
+used for inheritance, but only in the definitions that follow its own.
+
+A class binding binds the class name @class-name@ to the value of
+expression @class-expr@. It also binds the class type @class-name@ to
+the type of the class, and defines two type abbreviations :
+@class-name@ and @'#' class-name@. The first one is the type of
+objects of this class, while the second is more general as it unifies
+with the type of any object belonging to a subclass (see
+section~\ref{s:sharp-types}).
+
+\subsubsection*{Virtual class}
+
+A class must be flagged virtual if one of its methods is virtual (that
+is, appears in the class type, but is not actually defined).
+Objects cannot be created from a virtual class.
+
+\subsubsection*{Type parameters}
+
+The class type parameters correspond to the ones of the class type and
+of the two type abbreviations defined by the class binding. They must
+be bound to actual types in the class definition using type
+constraints. So that the abbreviations are well-formed, type
+variables of the inferred type of the class must either be type
+parameters or be bound in the constraint clause.
+
+\subsection{Class specifications}
+\label{s:class-spec}
+
+\ikwd{class\@\texttt{class}}
+\ikwd{and\@\texttt{and}}
+
+\begin{syntax}
+class-specification:
+ 'class' class-spec { 'and' class-spec }
+;
+class-spec:
+ ['virtual'] ['[' type-parameters ']'] class-name ':'
+ class-type
+\end{syntax}
+
+This is the counterpart in signatures of class definitions.
+A class specification matches a class definition if they have the same
+type parameters and their types match.
+
+\subsection{Class type definitions}
+\label{s:classtype}
+
+\ikwd{class\@\texttt{class}}
+\ikwd{type\@\texttt{type}}
+\ikwd{and\@\texttt{and}}
+
+\begin{syntax}
+classtype-definition:
+ 'class' 'type' classtype-def
+ { 'and' classtype-def }
+;
+classtype-def:
+ ['virtual'] ['[' type-parameters ']'] class-name '=' class-body-type
+\end{syntax}
+
+A class type definition @'class' class-name '=' class-body-type@
+defines an abbreviation @class-name@ for the class body type
+@class-body-type@. As for class definitions, two type abbreviations
+@class-name@ and @'#' class-name@ are also defined. The definition can
+be parameterized by some type parameters. If any method in the class
+type body is virtual, the definition must be flagged @'virtual'@.
+
+Two class type definitions match if they have the same type parameters
+and they expand to matching types.
--- /dev/null
+\section{Compilation units}
+\pdfsection{Compilation units}
+%HEVEA\cutname{compunit.html}
+
+\begin{syntax}
+unit-interface: { specification [';;'] }
+;
+unit-implementation: [ module-items ]
+\end{syntax}
+
+Compilation units bridge the module system and the separate
+compilation system. A compilation unit is composed of two parts: an
+interface and an implementation. The interface contains a sequence of
+specifications, just as the inside of a @'sig' \ldots 'end'@
+signature expression. The implementation contains a sequence of
+definitions and expressions, just as the inside of a
+@'struct' \ldots 'end'@ module
+expression. A compilation unit also has a name @unit-name@, derived
+from the names of the files containing the interface and the
+implementation (see chapter~\ref{c:camlc} for more details). A
+compilation unit behaves roughly as the module definition
+\begin{center}
+@'module' unit-name ':' 'sig' unit-interface 'end' '='
+ 'struct' unit-implementation 'end'@
+\end{center}
+
+A compilation unit can refer to other compilation units by their
+names, as if they were regular modules. For instance, if "U" is a
+compilation unit that defines a type "t", other compilation units can
+refer to that type under the name "U.t"; they can also refer to "U" as
+a whole structure. Except for names of other compilation units, a unit
+interface or unit implementation must not have any other free variables.
+In other terms, the type-checking and compilation of an interface or
+implementation proceeds in the initial environment
+\begin{center}
+@name_1 ':' 'sig' specification_1 'end' \ldots
+ name_n ':' 'sig' specification_n 'end'@
+\end{center}
+where @name_1 \ldots name_n@ are the names of the other
+compilation units available in the search path (see
+chapter~\ref{c:camlc} for more details) and @specification_1 \ldots
+specification_n@ are their respective interfaces.
--- /dev/null
+\section{Constants}
+\pdfsection{Constants}
+%HEVEA\cutname{const.html}
+
+\ikwd{false\@\texttt{false}}
+\ikwd{true\@\texttt{true}}
+\ikwd{begin\@\texttt{begin}}
+\ikwd{end\@\texttt{end}}
+
+\begin{syntax}
+constant:
+ integer-literal
+ | float-literal
+ | char-literal
+ | string-literal
+ | constr
+ | "false"
+ | "true"
+ | "("")"
+ | "begin" "end"
+ | "[""]"
+ | "[|""|]"
+ | "`"tag-name
+\end{syntax}
+See also the following language extensions:
+\hyperref[s:ext-integer]{integer literals for types \texttt{int32}, \texttt{int64}
+and \texttt{nativeint}}, \hyperref[s:quoted-strings]{quoted strings}
+and \hyperref[s:extension-literals]{extension literals}.
+
+The syntactic class of constants comprises literals from the four
+base types (integers, floating-point numbers, characters, character
+strings), and constant constructors from both normal and polymorphic
+variants, as well as the special constants @"false"@, @"true"@, @"("")"@,
+@"[""]"@, and @"[|""|]"@, which behave like constant constructors, and
+@"begin" "end"@, which is equivalent to @'('')'@.
--- /dev/null
+\section{Expressions\label{s:value-expr}}
+\pdfsection{Expressions}
+%HEVEA\cutname{expr.html}
+\ikwd{in\@\texttt{in}|see{\texttt{let}}}
+\ikwd{and\@\texttt{and}}
+\ikwd{rec\@\texttt{rec}|see{\texttt{let}, \texttt{module}}}
+\ikwd{let\@\texttt{let}}
+\ikwd{try\@\texttt{try}}
+\ikwd{function\@\texttt{function}}
+\ikwd{fun\@\texttt{fun}}
+\ikwd{with\@\texttt{with}}
+\ikwd{done\@\texttt{done}|see{\texttt{while}, \texttt{for}}}
+\ikwd{do\@\texttt{do}|see{\texttt{while}, \texttt{for}}}
+\ikwd{downto\@\texttt{downto}|see{\texttt{for}}}
+\ikwd{to\@\texttt{to}|see{\texttt{for}}}
+\ikwd{for\@\texttt{for}}
+\ikwd{else\@\texttt{else}|see{\texttt{if}}}
+\ikwd{then\@\texttt{then}|see{\texttt{if}}}
+\ikwd{if\@\texttt{if}}
+\ikwd{or\@\texttt{or}}
+\ikwd{match\@\texttt{match}}
+\ikwd{begin\@\texttt{begin}}
+\ikwd{end\@\texttt{end}}
+\ikwd{when\@\texttt{when}}
+\ikwd{new\@\texttt{new}}
+\ikwd{object\@\texttt{object}}
+\ikwd{lazy\@\texttt{lazy}}
+
+\begin{syntax}
+expr:
+ value-path
+ | constant
+ | '(' expr ')'
+ | 'begin' expr 'end'
+ | '(' expr ':' typexpr ')'
+ | expr {{',' expr}}
+ | constr expr
+ | "`"tag-name expr
+ | expr '::' expr
+ | '[' expr { ';' expr } [';'] ']'
+ | '[|' expr { ';' expr } [';'] '|]'
+ | '{' field [':' typexpr] ['=' expr]%
+ { ';' field [':' typexpr] ['=' expr] } [';'] '}'
+ | '{' expr 'with' field [':' typexpr] ['=' expr]%
+ { ';' field [':' typexpr] ['=' expr] } [';'] '}'
+ | expr {{ argument }}
+ | prefix-symbol expr
+ | '-' expr
+ | '-.' expr
+ | expr infix-op expr
+ | expr '.' field
+ | expr '.' field '<-' expr
+ | expr '.(' expr ')'
+ | expr '.(' expr ')' '<-' expr
+ | expr '.[' expr ']'
+ | expr '.[' expr ']' '<-' expr
+ | 'if' expr 'then' expr [ 'else' expr ]
+ | 'while' expr 'do' expr 'done'
+ | 'for' value-name '=' expr ( 'to' || 'downto' ) expr 'do' expr 'done'
+ | expr ';' expr
+ | 'match' expr 'with' pattern-matching
+ | 'function' pattern-matching
+ | 'fun' {{ parameter }} [ ':' typexpr ] '->' expr
+ | 'try' expr 'with' pattern-matching
+ | 'let' ['rec'] let-binding { 'and' let-binding } 'in' expr
+ | 'new' class-path
+ | 'object' class-body 'end'
+ | expr '#' method-name
+ | inst-var-name
+ | inst-var-name '<-' expr
+ | '(' expr ':>' typexpr ')'
+ | '(' expr ':' typexpr ':>' typexpr ')'
+ | '{<' [ inst-var-name '=' expr { ';' inst-var-name '=' expr } [';'] ] '>}'
+ | 'assert' expr
+ | 'lazy' expr
+ | 'let' 'module' module-name { '(' module-name ':' module-type ')' }
+ [ ':' module-type ] \\ '=' module-expr 'in' expr
+ | "let" "open" module-path "in" expr
+ | module-path '.(' expr ')'
+ | module-path '.[' expr ']'
+ | module-path '.[|' expr '|]'
+ | module-path '.{' expr '}'
+ | module-path '.{<' expr '>}'
+;
+%BEGIN LATEX
+\end{syntax} \begin{syntax}
+%END LATEX
+argument:
+ expr
+ | '~' label-name
+ | '~' label-name ':' expr
+ | '?' label-name
+ | '?' label-name ':' expr
+;
+%\end{syntax} \begin{syntax}
+pattern-matching:
+ [ '|' ] pattern ['when' expr] '->' expr
+ { '|' pattern ['when' expr] '->' expr }
+;
+let-binding:
+ pattern '=' expr
+ | value-name { parameter } [':' typexpr] [':>' typexpr] '=' expr
+ | value-name ':' poly-typexpr '=' expr %since 3.12
+;
+parameter:
+ pattern
+ | '~' label-name
+ | '~' '(' label-name [':' typexpr] ')'
+ | '~' label-name ':' pattern
+ | '?' label-name
+ | '?' '(' label-name [':' typexpr] ['=' expr] ')'
+ | '?' label-name ':' pattern
+ | '?' label-name ':' '(' pattern [':' typexpr] ['=' expr] ')'
+\end{syntax}
+See also the following language extensions:
+\hyperref[s:object-notations]{object notations},
+\hyperref[s-first-class-modules]{first-class modules},
+\hyperref[s:explicit-overriding-open]{overriding in open statements},
+\hyperref[s:bigarray-access]{syntax for Bigarray access},
+\hyperref[s:attributes]{attributes},
+\hyperref[s:extension-nodes]{extension nodes},
+\hyperref[s:local-exceptions]{local exceptions}
+\hyperref[s:index-operators]{extended indexing operators}.
+
+The table below shows the relative precedences and associativity of
+operators and non-closed constructions. The constructions with higher
+precedence come first. For infix and prefix symbols, we write
+``"*"\ldots'' to mean ``any symbol starting with "*"''.
+\ikwd{or\@\texttt{or}}%
+\ikwd{if\@\texttt{if}}%
+\ikwd{fun\@\texttt{fun}}%
+\ikwd{function\@\texttt{function}}%
+\ikwd{match\@\texttt{match}}%
+\ikwd{try\@\texttt{try}}%
+\ikwd{let\@\texttt{let}}%
+\ikwd{mod\@\texttt{mod}}
+\ikwd{land\@\texttt{land}}
+\ikwd{lor\@\texttt{lor}}
+\ikwd{lxor\@\texttt{lxor}}
+\ikwd{lsl\@\texttt{lsl}}
+\ikwd{lsr\@\texttt{lsr}}
+\ikwd{asr\@\texttt{asr}}
+\begin{tableau}{|l|l|}{Construction or operator}{Associativity}
+\entree{prefix-symbol}{--}
+\entree{". .( .[ .{" (see section~\ref{s:bigarray-access})}{--}
+\entree{"#"\ldots}{--}
+\entree{function application, constructor application, tag
+ application, "assert",
+ "lazy"}{left}
+\entree{"- -." (prefix)}{--}
+\entree{"**"\ldots" lsl lsr asr"}{right}
+\entree{"*"\ldots" /"\ldots" %"\ldots" mod land lor lxor"}{left}
+ %% "`"@ident@"`"
+\entree{"+"\ldots" -"\ldots}{left}
+\entree{"::"}{right}
+\entree{{\tt \char64}\ldots " ^"\ldots}{right}
+\entree{"="\ldots" <"\ldots" >"\ldots" |"\ldots" &"\ldots" $"\ldots" !="}{left}
+\entree{"& &&"}{right}
+\entree{"or ||"}{right}
+\entree{","}{--}
+\entree{"<- :="}{right}
+\entree{"if"}{--}
+\entree{";"}{right}
+\entree{"let match fun function try"}{--}
+\end{tableau}
+
+\subsection{Basic expressions}
+
+\subsubsection*{Constants}
+
+An expression consisting in a constant evaluates to this constant.
+
+\subsubsection*{Value paths} \label{expr:var}
+
+An expression consisting in an access path evaluates to the value bound to
+this path in the current evaluation environment. The path can
+be either a value name or an access path to a value component of a module.
+
+\subsubsection*{Parenthesized expressions}
+\ikwd{begin\@\texttt{begin}}
+\ikwd{end\@\texttt{end}}
+
+The expressions @'(' expr ')'@ and @'begin' expr 'end'@ have the same
+value as @expr@. The two constructs are semantically equivalent, but it
+is good style to use @'begin' \ldots 'end'@ inside control structures:
+\begin{alltt}
+ if \ldots then begin \ldots ; \ldots end else begin \ldots ; \ldots end
+\end{alltt}
+and @'(' \ldots ')'@ for the other grouping situations.
+
+Parenthesized expressions can contain a type constraint, as in @'('
+expr ':' typexpr ')'@. This constraint forces the type of @expr@ to be
+compatible with @typexpr@.
+
+Parenthesized expressions can also contain coercions
+@'(' expr [':' typexpr] ':>' typexpr')'@ (see
+subsection~\ref{s:coercions} below).
+
+
+\subsubsection*{Function application}
+
+Function application is denoted by juxtaposition of (possibly labeled)
+expressions. The expression @expr argument_1 \ldots argument_n@
+evaluates the expression @expr@ and those appearing in @argument_1@
+to @argument_n@. The expression @expr@ must evaluate to a
+functional value $f$, which is then applied to the values of
+@argument_1, \ldots, argument_n@.
+
+The order in which the expressions @expr, argument_1, \ldots,
+argument_n@ are evaluated is not specified.
+
+Arguments and parameters are matched according to their respective
+labels. Argument order is irrelevant, except among arguments with the
+same label, or no label.
+
+If a parameter is specified as optional (label prefixed by @"?"@) in the
+type of @expr@, the corresponding argument will be automatically
+wrapped with the constructor "Some", except if the argument itself is
+also prefixed by @"?"@, in which case it is passed as is.
+%
+If a non-labeled argument is passed, and its corresponding parameter
+is preceded by one or several optional parameters, then these
+parameters are {\em defaulted}, {\em i.e.} the value "None" will be
+passed for them.
+%
+All other missing parameters (without corresponding argument), both
+optional and non-optional, will be kept, and the result of the
+function will still be a function of these missing parameters to the
+body of $f$.
+
+As a special case, if the function has a known arity, all the
+arguments are unlabeled, and their number matches the number of
+non-optional parameters, then labels are ignored and non-optional
+parameters are matched in their definition order. Optional arguments
+are defaulted.
+
+In all cases but exact match of order and labels, without optional
+parameters, the function type should be known at the application
+point. This can be ensured by adding a type constraint. Principality
+of the derivation can be checked in the "-principal" mode.
+
+\subsubsection*{Function definition}
+
+Two syntactic forms are provided to define functions. The first form
+is introduced by the keyword "function":
+\ikwd{function\@\texttt{function}}
+
+$$\begin{array}{rlll}
+\token{function} & \textsl{pattern}_1 & \token{->} & \textsl{expr}_1 \\
+\token{|} & \ldots \\
+\token{|} & \textsl{pattern}_n & \token{->} & \textsl{expr}_n
+\end{array}$$
+This expression evaluates to a functional value with one argument.
+When this function is applied to a value \var{v}, this value is
+matched against each pattern @pattern_1@ to @pattern_n@.
+If one of these matchings succeeds, that is, if the value \var{v}
+matches the pattern @pattern_i@ for some \var{i},
+then the expression @expr_i@ associated to the selected pattern
+is evaluated, and its value becomes the value of the function
+application. The evaluation of @expr_i@ takes place in an
+environment enriched by the bindings performed during the matching.
+
+If several patterns match the argument \var{v}, the one that occurs
+first in the function definition is selected. If none of the patterns
+matches the argument, the exception "Match_failure" is raised.
+%
+\index{Matchfailure\@\verb`Match_failure`}
+
+\medskip
+
+The other form of function definition is introduced by the keyword "fun":
+\ikwd{fun\@\texttt{fun}}
+\begin{center}
+@"fun" parameter_1 \ldots parameter_n "->" expr@
+\end{center}
+This expression is equivalent to:
+\begin{center}
+@"fun" parameter_1 "->" \ldots "fun" parameter_n "->" expr@
+\end{center}
+
+An optional type constraint @typexpr@ can be added before "->" to enforce
+the type of the result to be compatible with the constraint @typexpr@:
+\begin{center}
+@"fun" parameter_1 \ldots parameter_n ":" typexpr "->" expr@
+\end{center}
+is equivalent to
+\begin{center}
+ @"fun" parameter_1 "->" \ldots "fun" parameter_n "->" %
+ (expr ":" typexpr )@
+\end{center}
+Beware of the small syntactic difference between a type constraint on
+the last parameter
+\begin{center}
+ @"fun" parameter_1 \ldots (parameter_n":"typexpr)"->" expr @
+\end{center}
+and one on the result
+\begin{center}
+ @"fun" parameter_1 \ldots parameter_n":" typexpr "->" expr @
+\end{center}
+
+The parameter patterns @"~"lab@ and @"~("lab [":" typ]")"@
+are shorthands for respectively @"~"lab":"lab@ and
+@"~"lab":("lab [":" typ]")"@, and similarly for their optional
+counterparts.
+
+A function of the form @"fun" "?" lab ":(" pattern '=' expr_0 ')' '->'
+expr@ is equivalent to
+\begin{center}
+@"fun" "?" lab ":" ident '->'
+ "let" pattern '='
+ "match" ident "with" "Some" ident "->" ident '|' "None" '->' expr_0
+ "in" expr@
+\end{center}
+where @ident@
+is a fresh variable, except that it is unspecified when @expr_0@ is evaluated.
+
+After these two transformations, expressions are of the form
+\begin{center}
+@"fun" [label_1] pattern_1 "->" \ldots "fun" [label_n] pattern_n "->" expr@
+\end{center}
+If we ignore labels, which will only be meaningful at function
+application, this is equivalent to
+\begin{center}
+@"function" pattern_1 "->" \ldots "function" pattern_n "->" expr@
+\end{center}
+That is, the @"fun"@ expression above evaluates to a curried function
+with \var{n} arguments: after applying this function $n$ times to the
+values @@v@_1 \ldots @v@_n@, the values will be matched
+in parallel against the patterns @pattern_1 \ldots pattern_n@.
+If the matching succeeds, the function returns the value of @expr@ in
+an environment enriched by the bindings performed during the matchings.
+If the matching fails, the exception "Match_failure" is raised.
+
+\subsubsection*{Guards in pattern-matchings}
+
+\ikwd{when\@\texttt{when}}
+The cases of a pattern matching (in the @"function"@, @"match"@ and
+@"try"@ constructs) can include guard expressions, which are
+arbitrary boolean expressions that must evaluate to "true" for the
+match case to be selected. Guards occur just before the @"->"@ token and
+are introduced by the @"when"@ keyword:
+
+$$\begin{array}{rlll}
+\token{function} & \nt{pattern}_1 \; [\token{when} \; \nt{cond}_1] & \token{->} & \nt{expr}_1 \\
+\token{|} & \ldots \\
+\token{|} & \nt{pattern}_n \; [\token{when} \; \nt{cond}_n] & \token{->} & \nt{expr}_n
+\end{array}$$
+
+
+Matching proceeds as described before, except that if the value
+matches some pattern @pattern_i@ which has a guard @@cond@_i@, then the
+expression @@cond@_i@ is evaluated (in an environment enriched by the
+bindings performed during matching). If @@cond@_i@ evaluates to "true",
+then @expr_i@ is evaluated and its value returned as the result of the
+matching, as usual. But if @@cond@_i@ evaluates to "false", the matching
+is resumed against the patterns following @pattern_i@.
+
+\subsubsection*{Local definitions} \label{s:localdef}
+
+\ikwd{let\@\texttt{let}}
+
+The @"let"@ and @"let" "rec"@ constructs bind value names locally.
+The construct
+\begin{center}
+@"let" pattern_1 "=" expr_1 "and" \ldots "and" pattern_n "=" expr_n "in" expr@
+\end{center}
+evaluates @expr_1 \ldots expr_n@ in some unspecified order and matches
+their values against the patterns @pattern_1 \ldots pattern_n@. If the
+matchings succeed, @expr@ is evaluated in the environment enriched by
+the bindings performed during matching, and the value of @expr@ is
+returned as the value of the whole @"let"@ expression. If one of the
+matchings fails, the exception "Match_failure" is raised.
+%
+\index{Matchfailure\@\verb`Match_failure`}
+
+An alternate syntax is provided to bind variables to functional
+values: instead of writing
+\begin{center}
+@"let" ident "=" "fun" parameter_1 \ldots parameter_m "->" expr@
+\end{center}
+in a @"let"@ expression, one may instead write
+\begin{center}
+@"let" ident parameter_1 \ldots parameter_m "=" expr@
+\end{center}
+
+\medskip
+\noindent
+Recursive definitions of names are introduced by @"let" "rec"@:
+\begin{center}
+@"let" "rec" pattern_1 "=" expr_1 "and" \ldots "and" pattern_n "=" expr_n
+ "in" expr@
+\end{center}
+The only difference with the @"let"@ construct described above is
+that the bindings of names to values performed by the
+pattern-matching are considered already performed when the expressions
+@expr_1@ to @expr_n@ are evaluated. That is, the expressions @expr_1@
+to @expr_n@ can reference identifiers that are bound by one of the
+patterns @pattern_1, \ldots, pattern_n@, and expect them to have the
+same value as in @expr@, the body of the @"let" "rec"@ construct.
+
+The recursive definition is guaranteed to behave as described above if
+the expressions @expr_1@ to @expr_n@ are function definitions
+(@"fun" \ldots@ or @"function" \ldots@), and the patterns @pattern_1
+\ldots pattern_n@ are just value names, as in:
+\begin{center}
+@"let" "rec" name_1 "=" "fun" \ldots
+"and" \ldots
+"and" name_n "=" "fun" \ldots
+"in" expr@
+\end{center}
+This defines @name_1 \ldots name_n@ as mutually recursive functions
+local to @expr@.
+
+The behavior of other forms of @"let" "rec"@ definitions is
+implementation-dependent. The current implementation also supports
+a certain class of recursive definitions of non-functional values,
+as explained in section~\ref{s:letrecvalues}.
+\subsubsection{Explicit polymorphic type annotations}
+(Introduced in OCaml 3.12)
+
+Polymorphic type annotations in @"let"@-definitions behave in a way
+similar to polymorphic methods:
+
+\begin{center}
+@"let" pattern_1 ":" typ_1 \ldots typ_n "." typeexpr "=" expr @
+\end{center}
+
+These annotations explicitly require the defined value to be polymorphic,
+and allow one to use this polymorphism in recursive occurrences
+(when using @"let" "rec"@). Note however that this is a normal polymorphic
+type, unifiable with any instance of itself.
+
+\subsection{Control structures}
+
+\subsubsection*{Sequence}
+
+The expression @expr_1 ";" expr_2@ evaluates @expr_1@ first, then
+@expr_2@, and returns the value of @expr_2@.
+
+\subsubsection*{Conditional}
+\ikwd{if\@\texttt{if}}
+
+The expression @"if" expr_1 "then" expr_2 "else" expr_3@ evaluates to
+the value of @expr_2@ if @expr_1@ evaluates to the boolean @"true"@,
+and to the value of @expr_3@ if @expr_1@ evaluates to the boolean
+@"false"@.
+
+The @"else" expr_3@ part can be omitted, in which case it defaults to
+@"else" "()"@.
+
+\subsubsection*{Case expression}\ikwd{match\@\texttt{match}}
+
+The expression
+$$\begin{array}{rlll}
+\token{match} & \textsl{expr} \\
+\token{with} & \textsl{pattern}_1 & \token{->} & \textsl{expr}_1 \\
+\token{|} & \ldots \\
+\token{|} & \textsl{pattern}_n & \token{->} & \textsl{expr}_n
+\end{array}$$
+matches the value of @expr@ against the patterns @pattern_1@ to
+@pattern_n@. If the matching against @pattern_i@ succeeds, the
+associated expression @expr_i@ is evaluated, and its value becomes the
+value of the whole @'match'@ expression. The evaluation of
+@expr_i@ takes place in an environment enriched by the bindings
+performed during matching. If several patterns match the value of
+@expr@, the one that occurs first in the @'match'@ expression is
+selected. If none of the patterns match the value of @expr@, the
+exception "Match_failure" is raised.
+%
+\index{Matchfailure\@\verb`Match_failure`}
+
+\subsubsection*{Boolean operators}
+
+The expression @expr_1 '&&' expr_2@ evaluates to @'true'@ if both
+@expr_1@ and @expr_2@ evaluate to @'true'@; otherwise, it evaluates to
+@'false'@. The first component, @expr_1@, is evaluated first. The
+second component, @expr_2@, is not evaluated if the first component
+evaluates to @'false'@. Hence, the expression @expr_1 '&&' expr_2@ behaves
+exactly as
+\begin{center}
+@'if' expr_1 'then' expr_2 'else' 'false'@.
+\end{center}
+
+The expression @expr_1 '||' expr_2@ evaluates to @'true'@ if one of
+the expressions
+@expr_1@ and @expr_2@ evaluates to @'true'@; otherwise, it evaluates to
+@'false'@. The first component, @expr_1@, is evaluated first. The
+second component, @expr_2@, is not evaluated if the first component
+evaluates to @'true'@. Hence, the expression @expr_1 '||' expr_2@ behaves
+exactly as
+\begin{center}
+@'if' expr_1 'then' 'true' 'else' expr_2@.
+\end{center}
+
+\ikwd{or\@\texttt{or}}
+The boolean operators @'&'@ and @'or'@ are deprecated synonyms for
+(respectively) @'&&'@ and @'||'@.
+
+\subsubsection*{Loops}
+
+\ikwd{while\@\texttt{while}}
+The expression @'while' expr_1 'do' expr_2 'done'@ repeatedly
+evaluates @expr_2@ while @expr_1@ evaluates to @'true'@. The loop
+condition @expr_1@ is evaluated and tested at the beginning of each
+iteration. The whole @'while' \ldots 'done'@ expression evaluates to
+the unit value @'()'@.
+
+\ikwd{for\@\texttt{for}}
+The expression @'for' name '=' expr_1 'to' expr_2 'do' expr_3 'done'@
+first evaluates the expressions @expr_1@ and @expr_2@ (the boundaries)
+into integer values \var{n} and \var{p}. Then, the loop body @expr_3@ is
+repeatedly evaluated in an environment where @name@ is successively
+bound to the values
+ $n$, $n+1$, \ldots, $p-1$, $p$.
+ The loop body is never evaluated if $n > p$.
+
+
+The expression @'for' name '=' expr_1 'downto' expr_2 'do' expr_3 'done'@
+evaluates similarly, except that @name@ is successively bound to the values
+ $n$, $n-1$, \ldots, $p+1$, $p$.
+ The loop body is never evaluated if $n < p$.
+
+
+In both cases, the whole @'for'@ expression evaluates to the unit
+value @'()'@.
+
+\subsubsection*{Exception handling}
+\ikwd{try\@\texttt{try}}
+
+The expression
+$$\begin{array}{rlll}
+\token{try~} & \textsl{expr} \\
+\token{with} & \textsl{pattern}_1 & \token{->} & \textsl{expr}_1 \\
+\token{|} & \ldots \\
+\token{|} & \textsl{pattern}_n & \token{->} & \textsl{expr}_n
+\end{array}$$
+evaluates the expression @expr@ and returns its value if the
+evaluation of @expr@ does not raise any exception. If the evaluation
+of @expr@ raises an exception, the exception value is matched against
+the patterns @pattern_1@ to @pattern_n@. If the matching against
+@pattern_i@ succeeds, the associated expression @expr_i@ is evaluated,
+and its value becomes the value of the whole @'try'@ expression. The
+evaluation of @expr_i@ takes place in an environment enriched by the
+bindings performed during matching. If several patterns match the value of
+@expr@, the one that occurs first in the @'try'@ expression is
+selected. If none of the patterns matches the value of @expr@, the
+exception value is raised again, thereby transparently ``passing
+through'' the @'try'@ construct.
+
+\subsection{Operations on data structures}
+
+\subsubsection*{Products}
+
+The expression @expr_1 ',' \ldots ',' expr_n@ evaluates to the
+\var{n}-tuple of the values of expressions @expr_1@ to @expr_n@. The
+evaluation order of the subexpressions is not specified.
+
+\subsubsection*{Variants}
+
+The expression @constr expr@ evaluates to the unary variant value
+whose constructor is @constr@, and whose argument is the value of
+@expr@. Similarly, the expression @constr '(' expr_1 ',' \ldots ','
+expr_n ')'@ evaluates to the n-ary variant value whose constructor is
+@constr@ and whose arguments are the values of @expr_1, \ldots,
+expr_n@.
+
+The expression @constr '('expr_1, \ldots, expr_n')'@ evaluates to the
+variant value whose constructor is @constr@, and whose arguments are
+the values of @expr_1 \ldots expr_n@.
+
+For lists, some syntactic sugar is provided. The expression
+@expr_1 '::' expr_2@ stands for the constructor @'(' '::' ')' @
+applied to the arguments @'(' expr_1 ',' expr_2 ')'@, and therefore
+evaluates to the list whose head is the value of @expr_1@ and whose tail
+is the value of @expr_2@. The expression @'[' expr_1 ';' \ldots ';'
+expr_n ']'@ is equivalent to @expr_1 '::' \ldots '::' expr_n '::'
+'[]'@, and therefore evaluates to the list whose elements are the
+values of @expr_1@ to @expr_n@.
+
+\subsubsection*{Polymorphic variants}
+
+The expression @"`"tag-name expr@ evaluates to the polymorphic variant
+value whose tag is @tag-name@, and whose argument is the value of @expr@.
+
+\subsubsection*{Records}
+
+The expression @'{' field_1 ['=' expr_1] ';' \ldots ';' field_n ['='
+expr_n ']}'@ evaluates to the record value
+$\{ field_1 = v_1; \ldots; field_n = v_n \}$
+where $v_i$ is the value of @expr_i@ for \fromoneto{i}{n}.
+A single identifier @field_k@ stands for @field_k '=' field_k@,
+and a qualified identifier @module-path '.' field_k@ stands for
+@module-path '.' field_k '=' field_k@.
+The fields @field_1@ to @field_n@ must all belong to the same record
+type; each field of this record type must appear exactly
+once in the record expression, though they can appear in any
+order. The order in which @expr_1@ to @expr_n@ are evaluated is not
+specified. Optional type constraints can be added after each field
+@'{' field_1 ':' typexpr_1 '=' expr_1 ';'%
+ \ldots ';' field_n ':' typexpr_n '=' expr_n '}'@
+to force the type of @field_k@ to be compatible with @typexpr_k@.
+
+The expression
+@"{" expr "with" field_1 ["=" expr_1] ";" \ldots ";" field_n ["=" expr_n] "}"@
+builds a fresh record with fields @field_1 \ldots field_n@ equal to
+@expr_1 \ldots expr_n@, and all other fields having the same value as
+in the record @expr@. In other terms, it returns a shallow copy of
+the record @expr@, except for the fields @field_1 \ldots field_n@,
+which are initialized to @expr_1 \ldots expr_n@. As previously,
+single identifier @field_k@ stands for @field_k '=' field_k@,
+a qualified identifier @module-path '.' field_k@ stands for
+@module-path '.' field_k '=' field_k@ and it is
+possible to add an optional type constraint on each field being updated
+with
+@"{" expr "with" field_1 ':' typexpr_1 "=" expr_1 ";" %
+ \ldots ";" field_n ':' typexpr_n "=" expr_n "}"@.
+
+The expression @expr_1 '.' field@ evaluates @expr_1@ to a record
+value, and returns the value associated to @field@ in this record
+value.
+
+The expression @expr_1 '.' field '<-' expr_2@ evaluates @expr_1@ to a record
+value, which is then modified in-place by replacing the value
+associated to @field@ in this record by the value of
+@expr_2@. This operation is permitted only if @field@ has been
+declared @'mutable'@ in the definition of the record type. The whole
+expression @expr_1 '.' field '<-' expr_2@ evaluates to the unit value
+@'()'@.
+
+\subsubsection*{Arrays}
+
+The expression @'[|' expr_1 ';' \ldots ';' expr_n '|]'@ evaluates to
+a \var{n}-element array, whose elements are initialized with the values of
+@expr_1@ to @expr_n@ respectively. The order in which these
+expressions are evaluated is unspecified.
+
+The expression @expr_1 '.(' expr_2 ')'@ returns the value of element
+number @expr_2@ in the array denoted by @expr_1@. The first element
+has number 0; the last element has number $n-1$, where \var{n} is the
+size of the array. The exception "Invalid_argument" is raised if the
+access is out of bounds.
+
+The expression @expr_1 '.(' expr_2 ')' '<-' expr_3@ modifies in-place
+the array denoted by @expr_1@, replacing element number @expr_2@ by
+the value of @expr_3@. The exception "Invalid_argument" is raised if
+the access is out of bounds. The value of the whole expression is @'()'@.
+
+\subsubsection*{Strings}
+
+The expression @expr_1 '.[' expr_2 ']'@ returns the value of character
+number @expr_2@ in the string denoted by @expr_1@. The first character
+has number 0; the last character has number $n-1$, where \var{n} is the
+length of the string. The exception "Invalid_argument" is raised if the
+access is out of bounds.
+
+The expression @expr_1 '.[' expr_2 ']' '<-' expr_3@ modifies in-place
+the string denoted by @expr_1@, replacing character number @expr_2@ by
+the value of @expr_3@. The exception "Invalid_argument" is raised if
+the access is out of bounds. The value of the whole expression is @'()'@.
+
+{\bf Note:} this possibility is offered only for backward
+compatibility with older versions of OCaml and will be removed in a
+future version. New code should use byte sequences and the "Bytes.set"
+function.
+
+\subsection{Operators}
+\ikwd{mod\@\texttt{mod}}
+\ikwd{land\@\texttt{land}}
+\ikwd{lor\@\texttt{lor}}
+\ikwd{lxor\@\texttt{lxor}}
+\ikwd{lsl\@\texttt{lsl}}
+\ikwd{lsr\@\texttt{lsr}}
+\ikwd{asr\@\texttt{asr}}
+
+Symbols from the class @infix-symbol@, as well as the keywords
+@"*"@, @"+"@, @"-"@, @'-.'@, @"="@, @"!="@, @"<"@, @">"@, @"or"@, @"||"@,
+@"&"@, @"&&"@, @":="@, @"mod"@, @"land"@, @"lor"@, @"lxor"@, @"lsl"@, @"lsr"@,
+and @"asr"@ can appear in infix position (between two
+expressions). Symbols from the class @prefix-symbol@, as well as
+the keywords @"-"@ and @"-."@
+can appear in prefix position (in front of an expression).
+
+Infix and prefix symbols do not have a fixed meaning: they are simply
+interpreted as applications of functions bound to the names
+corresponding to the symbols. The expression @prefix-symbol expr@ is
+interpreted as the application @'(' prefix-symbol ')'
+expr@. Similarly, the expression @expr_1 infix-symbol expr_2@ is
+interpreted as the application @'(' infix-symbol ')' expr_1 expr_2@.
+
+The table below lists the symbols defined in the initial environment
+and their initial meaning. (See the description of the core
+library module "Pervasives" in chapter~\ref{c:corelib} for more
+details). Their meaning may be changed at any time using
+@"let" "(" infix-op ")" name_1 name_2 "=" \ldots@
+
+Note: the operators @'&&'@, @'||'@, and @'~-'@ are handled specially
+and it is not advisable to change their meaning.
+
+The keywords @'-'@ and @'-.'@ can appear both as infix and
+prefix operators. When they appear as prefix operators, they are
+interpreted respectively as the functions @'(~-)'@ and @'(~-.)'@.
+
+%% Conversely, a regular function identifier can also be used as an infix
+%% operator by enclosing it in backquotes: @expr_1 '`' ident '`' expr_2@
+%% is interpreted as the application @ident expr_1 expr_2@.
+
+\ikwd{mod\@\texttt{mod}}%
+\ikwd{land\@\texttt{land}}%
+\ikwd{lor\@\texttt{lor}}%
+\ikwd{lxor\@\texttt{lxor}}%
+\ikwd{lsl\@\texttt{lsl}}%
+\ikwd{lsr\@\texttt{lsr}}%
+\ikwd{asr\@\texttt{asr}}%
+\begin{tableau}{|l|p{12cm}|}{Operator}{Initial meaning}
+\entree{"+"}{Integer addition.}
+\entree{"-" (infix)}{Integer subtraction.}
+\entree{"~- -" (prefix)}{Integer negation.}
+\entree{"*"}{Integer multiplication.}
+\entree{"/"}{Integer division.
+ Raise "Division_by_zero" if second argument is zero.}
+\entree{"mod"}{Integer modulus. Raise
+ "Division_by_zero" if second argument is zero.}
+\entree{"land"}{Bitwise logical ``and'' on integers.}
+\entree{"lor"}{Bitwise logical ``or'' on integers.}
+\entree{"lxor"}{Bitwise logical ``exclusive or'' on integers.}
+\entree{"lsl"}{Bitwise logical shift left on integers.}
+\entree{"lsr"}{Bitwise logical shift right on integers.}
+\entree{"asr"}{Bitwise arithmetic shift right on integers.}
+\entree{"+."}{Floating-point addition.}
+\entree{"-." (infix)}{Floating-point subtraction.}
+\entree{"~-. -." (prefix)}{Floating-point negation.}
+\entree{"*."}{Floating-point multiplication.}
+\entree{"/."}{Floating-point division.}
+\entree{"**"}{Floating-point exponentiation.}
+\entree{{\tt\char64} }{List concatenation.}
+\entree{"^" }{String concatenation.}
+\entree{"!" }{Dereferencing (return the current
+ contents of a reference).}
+\entree{":="}{Reference assignment (update the
+ reference given as first argument with the value of the second
+ argument).}
+\entree{"=" }{Structural equality test.}
+\entree{"<>" }{Structural inequality test.}
+\entree{"==" }{Physical equality test.}
+\entree{"!=" }{Physical inequality test.}
+\entree{"<" }{Test ``less than''.}
+\entree{"<=" }{Test ``less than or equal''.}
+\entree{">" }{Test ``greater than''.}
+\entree{">=" }{Test ``greater than or equal''.}
+\entree{"&& &"}{Boolean conjunction.}
+\entree{"|| or"}{Boolean disjunction.}
+\end{tableau}
+
+\subsection{Objects} \label{s:objects}
+
+\subsubsection*{Object creation}
+
+\ikwd{new\@\texttt{new}}
+
+When @class-path@ evaluates to a class body, @'new' class-path@
+evaluates to a new object containing the instance variables and
+methods of this class.
+
+When @class-path@ evaluates to a class function, @'new' class-path@
+evaluates to a function expecting the same number of arguments and
+returning a new object of this class.
+
+\subsubsection*{Immediate object creation}
+
+\ikwd{object\@\texttt{object}}
+
+Creating directly an object through the @'object' class-body 'end'@
+construct is operationally equivalent to defining locally a @'class'
+class-name '=' 'object' class-body 'end'@ ---see sections
+\ref{ss:class-body} and following for the syntax of @class-body@---
+and immediately creating a single object from it by @'new' class-name@.
+
+The typing of immediate objects is slightly different from explicitly
+defining a class in two respects. First, the inferred object type may
+contain free type variables. Second, since the class body of an
+immediate object will never be extended, its self type can be unified
+with a closed object type.
+
+\subsubsection*{Method invocation}
+
+The expression @expr '#' method-name@ invokes the method
+@method-name@ of the object denoted by @expr@.
+
+If @method-name@ is a polymorphic method, its type should be known at
+the invocation site. This is true for instance if @expr@ is the name
+of a fresh object (@'let' ident = 'new' class-path \dots @) or if
+there is a type constraint. Principality of the derivation can be
+checked in the "-principal" mode.
+
+\subsubsection*{Accessing and modifying instance variables}
+
+The instance variables of a class are visible only in the body of the
+methods defined in the same class or a class that inherits from the
+class defining the instance variables. The expression @inst-var-name@
+evaluates to the value of the given instance variable. The expression
+@inst-var-name '<-' expr@ assigns the value of @expr@ to the instance
+variable @inst-var-name@, which must be mutable. The whole expression
+@inst-var-name '<-' expr@ evaluates to @"()"@.
+
+
+\subsubsection*{Object duplication}
+
+An object can be duplicated using the library function "Oo.copy"
+(see
+\ifouthtml \ahref{libref/Oo.html}{Module \texttt{Oo}}\else
+section~\ref{Oo}\fi). Inside a method, the expression
+@ '{<' inst-var-name '=' expr { ';' inst-var-name '=' expr } '>}'@
+returns a copy of self with the given instance variables replaced by
+the values of the associated expressions; other instance variables
+have the same value in the returned object as in self.
+
+\subsection{Coercions} \label{s:coercions}
+
+Expressions whose type contains object or polymorphic variant types
+can be explicitly coerced (weakened) to a supertype.
+%
+The expression @'('expr ':>' typexpr')'@ coerces the expression @expr@
+to type @typexpr@.
+%
+The expression @'('expr ':' typexpr_1 ':>' typexpr_2')'@ coerces the
+expression @expr@ from type @typexpr_1@ to type @typexpr_2@.
+
+The former operator will sometimes fail to coerce an expression @expr@
+from a type @typ_1@ to a type @typ_2@
+even if type @typ_1@ is a subtype of type
+@typ_2@: in the current implementation it only expands two levels of
+type abbreviations containing objects and/or polymorphic variants,
+keeping only recursion when it is explicit in the class type (for objects).
+As an exception to the above algorithm, if both the inferred type of @expr@
+and @typ@ are ground ({\em i.e.} do not contain type variables), the
+former operator behaves as the latter one, taking the inferred type of
+@expr@ as @typ_1@. In case of failure with the former operator,
+the latter one should be used.
+
+It is only possible to coerce an expression @expr@ from type
+@typ_1@ to type @typ_2@, if the type of @expr@ is an instance of
+@typ_1@ (like for a type annotation), and @typ_1@ is a subtype
+of @typ_2@. The type of the coerced expression is an
+instance of @typ_2@. If the types contain variables,
+they may be instantiated by the subtyping algorithm, but this is only
+done after determining whether @typ_1@ is a potential subtype of
+@typ_2@. This means that typing may fail during this latter
+unification step, even if some instance of @typ_1@ is a subtype of
+some instance of @typ_2@.
+%
+In the following paragraphs we describe the subtyping relation used.
+
+\subsubsection*{Object types}
+
+A fixed object type admits as subtype any object type that includes all
+its methods. The types of the methods shall be subtypes of those in
+the supertype. Namely,
+\begin{center}
+@ '<' met_1 ':' typ_1 ';' \dots ';' met_n ':' typ_n '>' @
+\end{center}
+is a supertype of
+\begin{center}
+@ '<' met_1 ':' typ@$'_1$@ ';' \dots ';' met_n ':' typ@$'_n$@ ';'
+met@$_{n+1}$@ ':' typ@$'_{n+1}$@ ';' \dots ';' met@$_{n+m}$@ ':' typ@$'_{n+m}$@
+~[';' '..'] '>' @
+\end{center}
+which may contain an ellipsis ".." if every @typ_i@ is a supertype of
+the corresponding @typ@$'_i$.
+
+A monomorphic method type can be a supertype of a polymorphic method
+type. Namely, if @typ@ is an instance of @typ@$'$, then @ "'"@a@_1
+\dots "'"@a@_n '.' typ@$'$ is a subtype of @typ@.
+
+Inside a class definition, newly defined types are not available for
+subtyping, as the type abbreviations are not yet completely
+defined. There is an exception for coercing @@self@@ to the (exact)
+type of its class: this is allowed if the type of @@self@@ does not
+appear in a contravariant position in the class type, {\em i.e.} if
+there are no binary methods.
+
+\subsubsection*{Polymorphic variant types}
+
+A polymorphic variant type @typ@ is a subtype of another polymorphic
+variant type @typ@$'$ if the upper bound of @typ@ ({\em i.e.} the
+maximum set of constructors that may appear in an instance of @typ@)
+is included in the lower bound of @typ@$'$, and the types of arguments
+for the constructors of @typ@ are subtypes of those in
+@typ@$'$. Namely,
+\begin{center}
+@ "["["<"] "`"C_1 "of" typ_1 "|" \dots "|" "`"C_n "of" typ_n "]" @
+\end{center}
+which may be a shrinkable type, is a subtype of
+\begin{center}
+@ "["[">"] "`"C_1 "of" typ@$'_1$@ "|" \dots "|" "`"C_n "of" typ@$'_n$@
+ "|" "`"C@$_{n+1}$@ "of" typ@$'_{n+1}$@ "|" \dots "|" "`"C@$_{n+m}$@ "of"
+ typ@$'_{n+m}$@ "]" @
+\end{center}
+which may be an extensible type, if every @typ_i@ is a subtype of @typ@$'_i$.
+
+\subsubsection*{Variance}
+
+Other types do not introduce new subtyping, but they may propagate the
+subtyping of their arguments. For instance, @typ_1 "*" typ_2@ is a
+subtype of @typ@$'_1$@ "*" typ@$'_2$ when @typ_1@ and @typ_2@ are
+respectively subtypes of @typ@$'_1$ and @typ@$'_2$.
+For function types, the relation is more subtle:
+@typ_1 "->" typ_2@ is a subtype of @typ@$'_1$@~"->" typ@$'_2$
+if @typ_1@ is a supertype of @typ@$'_1$ and @typ_2@ is a
+subtype of @typ@$'_2$. For this reason, function types are covariant in
+their second argument (like tuples), but contravariant in their first
+argument. Mutable types, like "array" or "ref" are neither covariant
+nor contravariant, they are nonvariant, that is they do not propagate
+subtyping.
+
+For user-defined types, the variance is automatically inferred: a
+parameter is covariant if it has only covariant occurrences,
+contravariant if it has only contravariant occurrences,
+variance-free if it has no occurrences, and nonvariant otherwise.
+A variance-free parameter may change freely through subtyping, it does
+not have to be a subtype or a supertype.
+%
+For abstract and private types, the variance must be given explicitly
+(see section~\ref{s:type-defs}),
+otherwise the default is nonvariant. This is also the case for
+constrained arguments in type definitions.
+
+
+\subsection{Other}
+
+\subsubsection*{Assertion checking}
+
+
+\ikwd{assert\@\texttt{assert}}
+
+OCaml supports the @"assert"@ construct to check debugging assertions.
+The expression @"assert" expr@ evaluates the expression @expr@ and
+returns @"()"@ if @expr@ evaluates to @"true"@. If it evaluates to
+@"false"@ the exception
+"Assert_failure" is raised with the source file name and the
+location of @expr@ as arguments. Assertion
+checking can be turned off with the "-noassert" compiler option. In
+this case, @expr@ is not evaluated at all.
+
+As a special case, @"assert false"@ is reduced to
+@'raise' '('@"Assert_failure ..."@')'@, which gives it a polymorphic
+type. This means that it can be used in place of any expression (for
+example as a branch of any pattern-matching). It also means that
+the @"assert false"@ ``assertions'' cannot be turned off by the
+"-noassert" option.
+%
+\index{Assertfailure\@\verb`Assert_failure`}
+
+\subsubsection*{Lazy expressions}
+\ikwd{lazy\@\texttt{lazy}}
+
+The expression @"lazy" expr@ returns a value \var{v} of type "Lazy.t" that
+encapsulates the computation of @expr@. The argument @expr@ is not
+evaluated at this point in the program. Instead, its evaluation will
+be performed the first time the function "Lazy.force" is applied to the value
+\var{v}, returning the actual value of @expr@. Subsequent applications
+of "Lazy.force" to \var{v} do not evaluate @expr@ again. Applications
+of "Lazy.force" may be implicit through pattern matching (see~\ref{s:lazypat}).
+
+\subsubsection*{Local modules}
+\ikwd{let\@\texttt{let}}
+\ikwd{module\@\texttt{module}}
+
+The expression
+@"let" "module" module-name "=" module-expr "in" expr@
+locally binds the module expression @module-expr@ to the identifier
+@module-name@ during the evaluation of the expression @expr@.
+It then returns the value of @expr@. For example:
+\begin{verbatim}
+ let remove_duplicates comparison_fun string_list =
+ let module StringSet =
+ Set.Make(struct type t = string
+ let compare = comparison_fun end) in
+ StringSet.elements
+ (List.fold_right StringSet.add string_list StringSet.empty)
+\end{verbatim}
+
+\subsubsection*{Local opens}
+\ikwd{let\@\texttt{let}}
+\ikwd{module\@\texttt{open}}
+
+The expressions @"let" "open" module-path "in" expr@ and
+@module-path'.('expr')'@ are strictly equivalent. These
+constructions locally open the module referred to by the module path
+@module-path@ in the respective scope of the expression @expr@.
+
+When the body of a local open expression is delimited by
+@'[' ']'@, @'[|' '|]'@, or @'{' '}'@, the parentheses can be omitted.
+For expression, parentheses can also be omitted for @'{<' '>}'@.
+For example, @module-path'.['expr']'@ is equivalent to
+@module-path'.(['expr'])'@, and @module-path'.[|' expr '|]'@ is
+equivalent to @module-path'.([|' expr '|])'@.
+
+%% \newpage
--- /dev/null
+\chapter{Language extensions} \label{c:extensions}
+\pdfchapter{Language extensions}
+%HEVEA\cutname{extn.html}
+
+This chapter describes language extensions and convenience features
+that are implemented in OCaml, but not described in the
+OCaml reference manual.
+
+\section{Integer literals for types \texttt{int32}, \texttt{int64}
+ and \texttt{nativeint}} \label{s:ext-integer}
+
+(Introduced in Objective Caml 3.07)
+
+\begin{syntax}
+constant: ...
+ | int32-literal
+ | int64-literal
+ | nativeint-literal
+;
+int32-literal: integer-literal 'l'
+;
+int64-literal: integer-literal 'L'
+;
+nativeint-literal: integer-literal 'n'
+\end{syntax}
+
+An integer literal can be followed by one of the letters "l", "L" or "n"
+to indicate that this integer has type "int32", "int64" or "nativeint"
+respectively, instead of the default type "int" for integer literals.
+\index{int32\@\verb`int32`}
+\index{int64\@\verb`int64`}
+\index{nativeint\@\verb`nativeint`}
+The library modules "Int32"[\moduleref{Int32}],
+"Int64"[\moduleref{Int64}] and "Nativeint"[\moduleref{Nativeint}]
+provide operations on these integer types.
+
+\section{Recursive definitions of values} \label{s:letrecvalues}
+
+(Introduced in Objective Caml 1.00)
+
+As mentioned in section~\ref{s:localdef}, the @'let' 'rec'@ binding
+construct, in addition to the definition of recursive functions,
+also supports a certain class of recursive definitions of
+non-functional values, such as
+\begin{center}
+@"let" "rec" name_1 "=" "1" "::" name_2
+"and" name_2 "=" "2" "::" name_1
+"in" expr@
+\end{center}
+which binds @name_1@ to the cyclic list "1::2::1::2::"\ldots, and
+@name_2@ to the cyclic list "2::1::2::1::"\ldots
+Informally, the class of accepted definitions consists of those
+definitions where the defined names occur only inside function
+bodies or as argument to a data constructor.
+
+More precisely, consider the expression:
+\begin{center}
+@"let" "rec" name_1 "=" expr_1 "and" \ldots "and" name_n "=" expr_n "in" expr@
+\end{center}
+It will be accepted if each one of @expr_1 \ldots expr_n@ is
+statically constructive with respect to @name_1 \ldots name_n@,
+is not immediately linked to any of @name_1 \ldots name_n@,
+and is not an array constructor whose arguments have abstract type.
+
+An expression @@e@@ is said to be {\em statically constructive
+with respect to} the variables @name_1 \ldots name_n@ if at least
+one of the following conditions is true:
+\begin{itemize}
+\item @@e@@ has no free occurrence of any of @name_1 \ldots name_n@
+\item @@e@@ is a variable
+\item @@e@@ has the form @"fun" \ldots "->" \ldots@
+\item @@e@@ has the form @"function" \ldots "->" \ldots@
+\item @@e@@ has the form @"lazy" "(" \ldots ")"@
+\item @@e@@ has one of the following forms, where each one of
+ @expr_1 \ldots expr_m@ is statically constructive with respect to
+ @name_1 \ldots name_n@, and @expr_0@ is statically constructive with
+ respect to @name_1 \ldots name_n, xname_1 \ldots xname_m@:
+ \begin{itemize}
+ \item @"let" ["rec"] xname_1 "=" expr_1 "and" \ldots
+ "and" xname_m "=" expr_m "in" expr_0@
+ \item @"let" "module" \ldots "in" expr_1@
+ \item @constr "("expr_1"," \ldots "," expr_m")"@
+ \item @"`"tag-name "("expr_1"," \ldots "," expr_m")"@
+ \item @"[|" expr_1";" \ldots ";" expr_m "|]"@
+ \item @"{" field_1 "=" expr_1";" \ldots ";" field_m = expr_m "}"@
+ \item @"{" expr_1 "with" field_2 "=" expr_2";" \ldots ";"
+ field_m = expr_m "}"@ where @expr_1@ is not immediately
+ linked to @name_1 \ldots name_n@
+ \item @"(" expr_1"," \ldots "," expr_m ")"@
+ \item @expr_1";" \ldots ";" expr_m@
+ \end{itemize}
+\end{itemize}
+
+An expression @@e@@ is said to be {\em immediately linked to} the variable
+@name@ in the following cases:
+\begin{itemize}
+\item @@e@@ is @name@
+\item @@e@@ has the form @expr_1";" \ldots ";" expr_m@ where @expr_m@
+ is immediately linked to @name@
+\item @@e@@ has the form @"let" ["rec"] xname_1 "=" expr_1 "and" \ldots
+ "and" xname_m "=" expr_m "in" expr_0@ where @expr_0@ is immediately
+ linked to @name@ or to one of the @xname_i@ such that @expr_i@
+ is immediately linked to @name@.
+\end{itemize}
+
+\section{Lazy patterns} \label{s:lazypat}
+
+\ikwd{lazy\@\texttt{lazy}}
+
+(Introduced in Objective Caml 3.11)
+
+\begin{syntax}
+pattern: ...
+ | 'lazy' pattern
+\end{syntax}
+
+The pattern @"lazy" pattern@ matches a value \var{v} of type "Lazy.t",
+provided @pattern@ matches the result of forcing \var{v} with
+"Lazy.force". A successful match of a pattern containing @"lazy"@
+sub-patterns forces the corresponding parts of the value being matched, even
+those that imply no test such as @"lazy" value-name@ or @"lazy" "_"@.
+Matching a value with a @pattern-matching@ where some patterns
+contain @"lazy"@ sub-patterns may imply forcing parts of the value,
+even when the pattern selected in the end has no @"lazy"@ sub-pattern.
+
+For more information, see the description of module "Lazy" in the
+standard library (
+\ifouthtml
+\ahref{libref/Lazy.html}{Module \texttt{Lazy}}\else section~\ref{Lazy}\fi).
+%
+\index{Lazy (module)\@\verb`Lazy` (module)}%
+\index{force\@\verb`force`}%
+
+\section{Recursive modules} \label{s-recursive-modules}
+\ikwd{module\@\texttt{module}}
+\ikwd{and\@\texttt{and}}
+
+(Introduced in Objective Caml 3.07)
+
+% TODO: relaxed syntax
+
+\begin{syntax}
+definition:
+ ...
+ | 'module' 'rec' module-name ':' module-type '=' module-expr \\
+ { 'and' module-name ':' module-type '=' module-expr }
+;
+specification:
+ ...
+ | 'module' 'rec' module-name ':' module-type
+ { 'and' module-name':' module-type }
+\end{syntax}
+
+Recursive module definitions, introduced by the @"module rec"@ \ldots
+@"and"@ \ldots\ construction, generalize regular module definitions
+@'module' module-name '=' module-expr@ and module specifications
+@'module' module-name ':' module-type@ by allowing the defining
+@module-expr@ and the @module-type@ to refer recursively to the module
+identifiers being defined. A typical example of a recursive module
+definition is:
+\begin{verbatim}
+ module rec A : sig
+ type t = Leaf of string | Node of ASet.t
+ val compare: t -> t -> int
+ end
+ = struct
+ type t = Leaf of string | Node of ASet.t
+ let compare t1 t2 =
+ match (t1, t2) with
+ (Leaf s1, Leaf s2) -> Pervasives.compare s1 s2
+ | (Leaf _, Node _) -> 1
+ | (Node _, Leaf _) -> -1
+ | (Node n1, Node n2) -> ASet.compare n1 n2
+ end
+ and ASet : Set.S with type elt = A.t
+ = Set.Make(A)
+\end{verbatim}
+It can be given the following specification:
+\begin{verbatim}
+ module rec A : sig
+ type t = Leaf of string | Node of ASet.t
+ val compare: t -> t -> int
+ end
+ and ASet : Set.S with type elt = A.t
+\end{verbatim}
+
+This is an experimental extension of OCaml: the class of
+recursive definitions accepted, as well as its dynamic semantics are
+not final and subject to change in future releases.
+
+Currently, the compiler requires that all dependency cycles between
+the recursively-defined module identifiers go through at least one
+``safe'' module. A module is ``safe'' if all value definitions that
+it contains have function types @typexpr_1 '->' typexpr_2@. Evaluation of a
+recursive module definition proceeds by building initial values for
+the safe modules involved, binding all (functional) values to
+@'fun' '_' '->' 'raise' @"Undefined_recursive_module". The defining
+module expressions are then evaluated, and the initial values
+for the safe modules are replaced by the values thus computed. If a
+function component of a safe module is applied during this computation
+(which corresponds to an ill-founded recursive definition), the
+"Undefined_recursive_module" exception is raised at runtime:
+
+\begin{caml_example}{verbatim}
+module rec M: sig val f: unit -> int end = struct let f () = N.x end
+and N:sig val x: int end = struct let x = M.f () end
+\end{caml_example}
+
+If there are no safe modules along a dependency cycle, an error is raised
+
+\begin{caml_example}{verbatim}[error]
+module rec M: sig val x: int end = struct let x = N.y end
+and N:sig val x: int val y:int end = struct let x = M.x let y = 0 end
+\end{caml_example}
+
+Note that, in the @specification@ case, the @module-type@s must be
+parenthesized if they use the @'with' mod-constraint@ construct.
+
+\section{Private types}\label{s:private-types}
+\ikwd{private\@\texttt{private}}
+
+Private type declarations in module signatures, of the form
+"type t = private ...", enable libraries to
+reveal some, but not all aspects of the implementation of a type to
+clients of the library. In this respect, they strike a middle ground
+between abstract type declarations, where no information is revealed
+on the type implementation, and data type definitions and type
+abbreviations, where all aspects of the type implementation are
+publicized. Private type declarations come in three flavors: for
+variant and record types (section~\ref{s-private-types-variant}),
+for type abbreviations (section~\ref{s-private-types-abbrev}),
+and for row types (section~\ref{s-private-rows}).
+
+\subsection{Private variant and record types} \label{s-private-types-variant}
+
+(Introduced in Objective Caml 3.07)
+
+\begin{syntax}
+type-representation:
+ ...
+ | '=' 'private' [ '|' ] constr-decl { '|' constr-decl }
+ | '=' 'private' record-decl
+\end{syntax}
+
+Values of a variant or record type declared @"private"@
+can be de-structured normally in pattern-matching or via
+the @expr '.' field@ notation for record accesses. However, values of
+these types cannot be constructed directly by constructor application
+or record construction. Moreover, assignment on a mutable field of a
+private record type is not allowed.
+
+The typical use of private types is in the export signature of a
+module, to ensure that construction of values of the private type always
+go through the functions provided by the module, while still allowing
+pattern-matching outside the defining module. For example:
+\begin{verbatim}
+ module M : sig
+ type t = private A | B of int
+ val a : t
+ val b : int -> t
+ end
+ = struct
+ type t = A | B of int
+ let a = A
+ let b n = assert (n > 0); B n
+ end
+\end{verbatim}
+Here, the @"private"@ declaration ensures that in any value of type
+"M.t", the argument to the "B" constructor is always a positive integer.
+
+With respect to the variance of their parameters, private types are
+handled like abstract types. That is, if a private type has
+parameters, their variance is the one explicitly given by prefixing
+the parameter by a `"+"' or a `"-"', it is invariant otherwise.
+
+\subsection{Private type abbreviations} \label{s-private-types-abbrev}
+
+(Introduced in Objective Caml 3.11)
+
+\begin{syntax}
+type-equation:
+ ...
+ | '=' 'private' typexpr
+\end{syntax}
+
+Unlike a regular type abbreviation, a private type abbreviation
+declares a type that is distinct from its implementation type @typexpr@.
+However, coercions from the type to @typexpr@ are permitted.
+Moreover, the compiler ``knows'' the implementation type and can take
+advantage of this knowledge to perform type-directed optimizations.
+
+The following example uses a private type abbreviation to define a
+module of nonnegative integers:
+\begin{verbatim}
+ module N : sig
+ type t = private int
+ val of_int: int -> t
+ val to_int: t -> int
+ end
+ = struct
+ type t = int
+ let of_int n = assert (n >= 0); n
+ let to_int n = n
+ end
+\end{verbatim}
+The type "N.t" is incompatible with "int", ensuring that nonnegative
+integers and regular integers are not confused. However, if "x" has
+type "N.t", the coercion "(x :> int)" is legal and returns the
+underlying integer, just like "N.to_int x". Deep coercions are also
+supported: if "l" has type "N.t list", the coercion "(l :> int list)"
+returns the list of underlying integers, like "List.map N.to_int l"
+but without copying the list "l".
+
+Note that the coercion @"(" expr ":>" typexpr ")"@ is actually an abbreviated
+form,
+and will only work in presence of private abbreviations if neither the
+type of @expr@ nor @typexpr@ contain any type variables. If they do,
+you must use the full form @"(" expr ":" typexpr_1 ":>" typexpr_2 ")"@ where
+@typexpr_1@ is the expected type of @expr@. Concretely, this would be "(x :
+N.t :> int)" and "(l : N.t list :> int list)" for the above examples.
+
+\subsection{Private row types} \label{s-private-rows}
+\ikwd{private\@\texttt{private}}
+
+(Introduced in Objective Caml 3.09)
+
+\begin{syntax}
+type-equation:
+ ...
+ | '=' 'private' typexpr
+\end{syntax}
+
+Private row types are type abbreviations where part of the
+structure of the type is left abstract. Concretely @typexpr@ in the
+above should denote either an object type or a polymorphic variant
+type, with some possibility of refinement left. If the private
+declaration is used in an interface, the corresponding implementation
+may either provide a ground instance, or a refined private type.
+\begin{verbatim}
+ module M : sig type c = private < x : int; .. > val o : c end =
+ struct
+ class c = object method x = 3 method y = 2 end
+ let o = new c
+ end
+\end{verbatim}
+This declaration does more than hiding the "y" method, it also makes
+the type "c" incompatible with any other closed object type, meaning
+that only "o" will be of type "c". In that respect it behaves
+similarly to private record types. But private row types are
+more flexible with respect to incremental refinement. This feature can
+be used in combination with functors.
+\begin{verbatim}
+ module F(X : sig type c = private < x : int; .. > end) =
+ struct
+ let get_x (o : X.c) = o#x
+ end
+ module G(X : sig type c = private < x : int; y : int; .. > end) =
+ struct
+ include F(X)
+ let get_y (o : X.c) = o#y
+ end
+\end{verbatim}
+
+A polymorphic variant type [t], for example
+\begin{verbatim}
+ type t = [ `A of int | `B of bool ]
+\end{verbatim}
+can be refined in two ways. A definition [u] may add new field to [t],
+and the declaration
+\begin{verbatim}
+ type u = private [> t]
+\end{verbatim}
+will keep those new fields abstract. Construction of values of type
+[u] is possible using the known variants of [t], but any
+pattern-matching will require a default case to handle the potential
+extra fields. Dually, a declaration [u] may restrict the fields of [t]
+through abstraction: the declaration
+\begin{verbatim}
+ type v = private [< t > `A]
+\end{verbatim}
+corresponds to private variant types. One cannot create a value of the
+private type [v], except using the constructors that are explicitly
+listed as present, "(`A n)" in this example; yet, when
+patter-matching on a [v], one should assume that any of the
+constructors of [t] could be present.
+
+Similarly to abstract types, the variance of type parameters
+is not inferred, and must be given explicitly.
+
+
+\section{Local opens for patterns}
+\ikwd{let\@\texttt{let}}
+\ikwd{open\@\texttt{open}} \label{s:local-opens}
+
+(Introduced in OCaml 4.04)
+
+\begin{syntax}
+pattern:
+ ...
+ | module-path '.(' pattern ')'
+ | module-path '.[' pattern ']'
+ | module-path '.[|' pattern '|]'
+ | module-path '.{' pattern '}'
+
+\end{syntax}
+
+For patterns, local opens are limited to the
+@module-path'.('pattern')'@ construction. This
+construction locally open the module referred to by the module path
+@module-path@ in the scope of the pattern @pattern@.
+
+When the body of a local open pattern is delimited by
+@'[' ']'@, @'[|' '|]'@, or @'{' '}'@, the parentheses can be omitted.
+For example, @module-path'.['pattern']'@ is equivalent to
+@module-path'.(['pattern'])'@, and @module-path'.[|' pattern '|]'@ is
+equivalent to @module-path'.([|' pattern '|])'@.
+
+\section{Object copy short notations} \label{s:object-notations}
+\ikwd{with\@\texttt{with}}
+
+(Introduced in OCaml 4.03)
+
+\begin{syntax}
+expr:
+ ...
+ | '{' '<' expr 'with' field ['=' expr] { ';' field ['=' expr] } [';'] '>' '}'
+\end{syntax}
+
+In an object copy expression,
+a single identifier @id@ stands for @id '=' id@, and a qualified identifier
+@module-path '.' id@ stands for @module-path '.' id '=' id@.
+For example, all following methods are equivalent:
+\begin{verbatim}
+ object
+ val x=0. val y=0. val z=0.
+ method f_0 x y = {< x; y >}
+ method f_1 x y = {< x = x; y >}
+ method f_2 x y = {< x=x ; y = y >}
+ end
+\end{verbatim}
+
+\section{Locally abstract types}
+\ikwd{type\@\texttt{type}}
+\ikwd{fun\@\texttt{fun}} \label{s:locally-abstract}
+
+(Introduced in OCaml 3.12, short syntax added in 4.03)
+
+\begin{syntax}
+parameter:
+ ...
+ | '(' "type" {{typeconstr-name}} ')'
+\end{syntax}
+
+The expression @"fun" '(' "type" typeconstr-name ')' "->" expr@ introduces a
+type constructor named @typeconstr-name@ which is considered abstract
+in the scope of the sub-expression, but then replaced by a fresh type
+variable. Note that contrary to what the syntax could suggest, the
+expression @"fun" '(' "type" typeconstr-name ')' "->" expr@ itself does not
+suspend the evaluation of @expr@ as a regular abstraction would. The
+syntax has been chosen to fit nicely in the context of function
+declarations, where it is generally used. It is possible to freely mix
+regular function parameters with pseudo type parameters, as in:
+\begin{caml_example*}{verbatim}
+ let f = fun (type t) (foo : t list) -> assert false[@ellipsis]
+\end{caml_example*}
+and even use the alternative syntax for declaring functions:
+\begin{caml_example*}{verbatim}
+ let f (type t) (foo : t list) = assert false[@ellipsis]
+\end{caml_example*}
+If several locally abstract types need to be introduced, it is possible to use
+the syntax
+@"fun" '(' "type" typeconstr-name_1 \ldots typeconstr-name_n ')' "->" expr@
+as syntactic sugar for @"fun" '(' "type" typeconstr-name_1 ')' "->" \ldots "->"
+"fun" '(' "type" typeconstr-name_n ')' "->" expr@. For instance,
+\begin{caml_example*}{verbatim}
+ let f = fun (type t u v) -> fun (foo : (t * u * v) list) -> assert false[@ellipsis]
+ let f' (type t u v) (foo : (t * u * v) list) = assert false[@ellipsis]
+\end{caml_example}
+
+This construction is useful because the type constructors it introduces
+can be used in places where a type variable is not allowed. For
+instance, one can use it to define an exception in a local module
+within a polymorphic function.
+\begin{verbatim}
+ let f (type t) () =
+ let module M = struct exception E of t end in
+ (fun x -> M.E x), (function M.E x -> Some x | _ -> None)
+\end{verbatim}
+
+Here is another example:
+\begin{verbatim}
+ let sort_uniq (type s) (cmp : s -> s -> int) =
+ let module S = Set.Make(struct type t = s let compare = cmp end) in
+ fun l ->
+ S.elements (List.fold_right S.add l S.empty)
+\end{verbatim}
+
+It is also extremely useful for first-class modules (see
+section~\ref{s-first-class-modules}) and generalized algebraic datatypes
+(GADTs: see section~\ref{s:gadts}).
+
+\paragraph{Polymorphic syntax} (Introduced in OCaml 4.00)
+
+\begin{syntax}
+let-binding:
+ ...
+ | value-name ':' 'type' {{ typeconstr-name }} '.' typexpr '=' expr
+;
+class-field:
+ ...
+ | 'method' ['private'] method-name ':' 'type'
+ {{ typeconstr-name }} '.' typexpr '=' expr
+ | 'method!' ['private'] method-name ':' 'type'
+ {{ typeconstr-name }} '.' typexpr '=' expr
+\end{syntax}
+
+The @"(type" typeconstr-name")"@ syntax construction by itself does not make
+polymorphic the type variable it introduces, but it can be combined
+with explicit polymorphic annotations where needed.
+The above rule is provided as syntactic sugar to make this easier:
+\begin{caml_example*}{verbatim}
+ let rec f : type t1 t2. t1 * t2 list -> t1 = assert false[@ellipsis]
+\end{caml_example*}
+\noindent
+is automatically expanded into
+\begin{caml_example*}{verbatim}
+ let rec f : 't1 't2. 't1 * 't2 list -> 't1 =
+ fun (type t1) (type t2) -> ( assert false[@ellipsis] : t1 * t2 list -> t1)
+\end{caml_example*}
+This syntax can be very useful when defining recursive functions involving
+GADTs, see the section~\ref{s:gadts} for a more detailed explanation.
+
+The same feature is provided for method definitions.
+
+\section{First-class modules}\label{s-first-class-modules}
+\ikwd{module\@\texttt{module}}
+\ikwd{val\@\texttt{val}}
+\ikwd{with\@\texttt{with}}
+\ikwd{and\@\texttt{and}}
+
+(Introduced in OCaml 3.12; pattern syntax and package type inference
+introduced in 4.00; structural comparison of package types introduced in 4.02.;
+fewer parens required starting from 4.05)
+
+\begin{syntax}
+typexpr:
+ ...
+ | '(''module' package-type')'
+;
+module-expr:
+ ...
+ | '(''val' expr [':' package-type]')'
+;
+expr:
+ ...
+ | '(''module' module-expr [':' package-type]')'
+;
+pattern:
+ ...
+ | '(''module' module-name [':' package-type]')'
+;
+package-type:
+ modtype-path
+ | modtype-path 'with' package-constraint { 'and' package-constraint }
+;
+package-constraint:
+ 'type' typeconstr '=' typexpr
+;
+\end{syntax}
+
+Modules are typically thought of as static components. This extension
+makes it possible to pack a module as a first-class value, which can
+later be dynamically unpacked into a module.
+
+The expression @'(' 'module' module-expr ':' package-type ')'@ converts the
+module (structure or functor) denoted by module expression @module-expr@
+to a value of the core language that encapsulates this module. The
+type of this core language value is @'(' 'module' package-type ')'@.
+The @package-type@ annotation can be omitted if it can be inferred
+from the context.
+
+Conversely, the module expression @'(' 'val' expr ':' package-type ')'@
+evaluates the core language expression @expr@ to a value, which must
+have type @'module' package-type@, and extracts the module that was
+encapsulated in this value. Again @package-type@ can be omitted if the
+type of @expr@ is known.
+If the module expression is already parenthesized, like the arguments
+of functors are, no additional parens are needed: "Map.Make(val key)".
+
+The pattern @'(' 'module' module-name ':' package-type ')'@ matches a
+package with type @package-type@ and binds it to @module-name@.
+It is not allowed in toplevel let bindings.
+Again @package-type@ can be omitted if it can be inferred from the
+enclosing pattern.
+
+The @package-type@ syntactic class appearing in the @'(' 'module'
+package-type ')'@ type expression and in the annotated forms represents a
+subset of module types.
+This subset consists of named module types with optional constraints
+of a limited form: only non-parametrized types can be specified.
+
+For type-checking purposes (and starting from OCaml 4.02), package types
+are compared using the structural comparison of module types.
+
+In general, the module expression @'(' "val" expr ":" package-type
+')'@ cannot be used in the body of a functor, because this could cause
+unsoundness in conjunction with applicative functors.
+Since OCaml 4.02, this is relaxed in two ways:
+if @package-type@ does not contain nominal type declarations ({\em
+ i.e.} types that are created with a proper identity), then this
+expression can be used anywhere, and even if it contains such types
+it can be used inside the body of a generative
+functor, described in section~\ref{s:generative-functors}.
+It can also be used anywhere in the context of a local module binding
+@'let' 'module' module-name '=' '(' "val" expr_1 ":" package-type ')'
+ "in" expr_2@.
+
+\paragraph{Basic example} A typical use of first-class modules is to
+select at run-time among several implementations of a signature.
+Each implementation is a structure that we can encapsulate as a
+first-class module, then store in a data structure such as a hash
+table:
+\begin{caml_example*}{verbatim}
+ module type DEVICE = sig [@@@ellipsis] end
+ let devices : (string, (module DEVICE)) Hashtbl.t = Hashtbl.create 17
+
+ module SVG = struct [@@@ellipsis] end
+ let _ = Hashtbl.add devices "SVG" (module SVG : DEVICE)
+
+ module PDF = struct [@@@ellipsis] end
+ let _ = Hashtbl.add devices "PDF" (module PDF: DEVICE)
+\end{caml_example*}
+We can then select one implementation based on command-line
+arguments, for instance:
+\begin{verbatim}
+ module Device =
+ (val (try Hashtbl.find devices (parse_cmdline())
+ with Not_found -> eprintf "Unknown device %s\n"; exit 2)
+ : DEVICE)
+\end{verbatim}
+Alternatively, the selection can be performed within a function:
+\begin{verbatim}
+ let draw_using_device device_name picture =
+ let module Device =
+ (val (Hashtbl.find devices device_name) : DEVICE)
+ in
+ Device.draw picture
+\end{verbatim}
+
+\paragraph{Advanced examples}
+With first-class modules, it is possible to parametrize some code over the
+implementation of a module without using a functor.
+
+\begin{verbatim}
+ let sort (type s) (module Set : Set.S with type elt = s) l =
+ Set.elements (List.fold_right Set.add l Set.empty)
+ val sort : (module Set.S with type elt = 'a) -> 'a list -> 'a list
+\end{verbatim}
+
+To use this function, one can wrap the "Set.Make" functor:
+
+\begin{verbatim}
+ let make_set (type s) cmp =
+ let module S = Set.Make(struct
+ type t = s
+ let compare = cmp
+ end) in
+ (module S : Set.S with type elt = s)
+ val make_set : ('a -> 'a -> int) -> (module Set.S with type elt = 'a)
+\end{verbatim}
+
+\iffalse
+Another advanced use of first-class module is to encode existential
+types. In particular, they can be used to simulate generalized
+algebraic data types (GADT). To demonstrate this, we first define a type
+of witnesses for type equalities:
+
+\begin{verbatim}
+ module TypEq : sig
+ type ('a, 'b) t
+ val apply: ('a, 'b) t -> 'a -> 'b
+ val refl: ('a, 'a) t
+ val sym: ('a, 'b) t -> ('b, 'a) t
+ end = struct
+ type ('a, 'b) t = ('a -> 'b) * ('b -> 'a)
+ let refl = (fun x -> x), (fun x -> x)
+ let apply (f, _) x = f x
+ let sym (f, g) = (g, f)
+ end
+\end{verbatim}
+
+We can then define a parametrized algebraic data type whose
+constructors provide some information about the type parameter:
+
+\begin{verbatim}
+ module rec Typ : sig
+ module type PAIR = sig
+ type t and t1 and t2
+ val eq: (t, t1 * t2) TypEq.t
+ val t1: t1 Typ.typ
+ val t2: t2 Typ.typ
+ end
+
+ type 'a typ =
+ | Int of ('a, int) TypEq.t
+ | String of ('a, string) TypEq.t
+ | Pair of (module PAIR with type t = 'a)
+ end = Typ
+\end{verbatim}
+
+Values of type "'a typ" are supposed to be runtime representations for
+the type "'a". The constructors "Int" and "String" are easy: they
+directly give a witness of type equality between the parameter "'a"
+and the ground types "int" (resp. "string"). The constructor "Pair" is
+more complex. One wants to give a witness of type equality between
+"'a" and a type of the form "t1 * t2" together with the representations
+for "t1" and "t2". However, these two types are unknown. The code above
+shows how to use first-class modules to simulate existentials.
+
+Here is how to construct values of type "'a typ":
+
+\begin{verbatim}
+ let int = Typ.Int TypEq.refl
+
+ let str = Typ.String TypEq.refl
+
+ let pair (type s1) (type s2) t1 t2 =
+ let module P = struct
+ type t = s1 * s2
+ type t1 = s1
+ type t2 = s2
+ let eq = TypEq.refl
+ let t1 = t1
+ let t2 = t2
+ end in
+ let pair = (module P : Typ.PAIR with type t = s1 * s2) in
+ Typ.Pair pair
+\end{verbatim}
+
+And finally, here is an example of a polymorphic function that takes the
+runtime representation of some type "'a" and a value of the same type,
+then pretty-prints the value into a string:
+
+\begin{verbatim}
+ open Typ
+ let rec to_string: 'a. 'a Typ.typ -> 'a -> string =
+ fun (type s) t x ->
+ match t with
+ | Int eq -> string_of_int (TypEq.apply eq x)
+ | String eq -> Printf.sprintf "%S" (TypEq.apply eq x)
+ | Pair p ->
+ let module P = (val p : PAIR with type t = s) in
+ let (x1, x2) = TypEq.apply P.eq x in
+ Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2)
+\end{verbatim}
+
+Note that this function uses an explicit polymorphic annotation to obtain
+polymorphic recursion.
+\fi
+
+\section{Recovering the type of a module} \label{s:module-type-of}
+
+\ikwd{module\@\texttt{module}}
+\ikwd{type\@\texttt{type}}
+\ikwd{of\@\texttt{of}}
+\ikwd{include\@\texttt{include}}
+
+(Introduced in OCaml 3.12)
+
+\begin{syntax}
+module-type:
+ ...
+ | 'module' 'type' 'of' module-expr
+\end{syntax}
+
+The construction @'module' 'type' 'of' module-expr@ expands to the module type
+(signature or functor type) inferred for the module expression @module-expr@.
+To make this module type reusable in many situations, it is
+intentionally not strengthened: abstract types and datatypes are not
+explicitly related with the types of the original module.
+For the same reason, module aliases in the inferred type are expanded.
+
+A typical use, in conjunction with the signature-level @'include'@
+construct, is to extend the signature of an existing structure.
+In that case, one wants to keep the types equal to types in the
+original module. This can done using the following idiom.
+\begin{verbatim}
+ module type MYHASH = sig
+ include module type of struct include Hashtbl end
+ val replace: ('a, 'b) t -> 'a -> 'b -> unit
+ end
+\end{verbatim}
+The signature "MYHASH" then contains all the fields of the signature
+of the module "Hashtbl" (with strengthened type definitions), plus the
+new field "replace". An implementation of this signature can be
+obtained easily by using the @'include'@ construct again, but this
+time at the structure level:
+\begin{verbatim}
+ module MyHash : MYHASH = struct
+ include Hashtbl
+ let replace t k v = remove t k; add t k v
+ end
+\end{verbatim}
+
+Another application where the absence of strengthening comes handy, is
+to provide an alternative implementation for an existing module.
+\begin{verbatim}
+ module MySet : module type of Set = struct
+ ...
+ end
+\end{verbatim}
+This idiom guarantees that "Myset" is compatible with Set, but allows
+it to represent sets internally in a different way.
+
+\section{Substituting inside a signature}
+\ikwd{with\@\texttt{with}}
+\ikwd{module\@\texttt{module}}
+\ikwd{type\@\texttt{type}}
+\label{s:signature-substitution}
+
+(Introduced in OCaml 3.12, generalized in 4.06)
+
+\begin{syntax}
+mod-constraint:
+ ...
+ | 'type' [type-params] typeconstr-name ':=' typexpr
+ | 'module' module-path ':=' extended-module-path
+\end{syntax}
+
+A ``destructive'' substitution (@'with' ... ':=' ...@) behaves essentially like
+normal signature constraints (@'with' ... '=' ...@), but it additionally removes
+the redefined type or module from the signature.
+
+Prior to OCaml 4.06, there were a number of restrictions: one could only remove
+types and modules at the outermost level (not inside submodules), and in the
+case of @'with type'@ the definition had to be another type constructor with the
+same type parameters.
+
+A natural application of destructive substitution is merging two
+signatures sharing a type name.
+\begin{caml_example*}{verbatim}
+ module type Printable = sig
+ type t
+ val print : Format.formatter -> t -> unit
+ end
+ module type Comparable = sig
+ type t
+ val compare : t -> t -> int
+ end
+ module type PrintableComparable = sig
+ include Printable
+ include Comparable with type t := t
+ end
+\end{caml_example*}
+
+One can also use this to completely remove a field:
+\begin{caml_example}{verbatim}
+module type S = Comparable with type t := int
+\end{caml_example}
+or to rename one:
+\begin{caml_example}{verbatim}
+module type S = sig
+ type u
+ include Comparable with type t := u
+end
+\end{caml_example}
+
+Note that you can also remove manifest types, by substituting with the
+same type.
+\begin{caml_example}{verbatim}
+module type ComparableInt = Comparable with type t = int ;;
+module type CompareInt = ComparableInt with type t := int
+\end{caml_example}
+
+\section{Type-level module aliases}
+\ikwd{module\@\texttt{module}}
+\label{s:module-alias}
+
+(Introduced in OCaml 4.02)
+
+\begin{syntax}
+specification:
+ ...
+ | 'module' module-name '=' module-path
+\end{syntax}
+
+The above specification, inside a signature, only matches a module
+definition equal to @module-path@. Conversely, a type-level module
+alias can be matched by itself, or by any supertype of the type of the
+module it references.
+
+There are several restrictions on @module-path@:
+\begin{enumerate}
+\item it should be of the form \(M_0.M_1...M_n\) ({\em i.e.} without
+ functor applications);
+\item inside the body of a functor, \(M_0\) should not be one of the
+ functor parameters;
+\item inside a recursive module definition, \(M_0\) should not be one of
+ the recursively defined modules.
+\end{enumerate}
+
+Such specifications are also inferred. Namely, when @P@ is a path
+satisfying the above constraints,
+\begin{caml_eval}
+module P = struct end
+\end{caml_eval}
+\begin{caml_example*}{verbatim}
+module N = P
+\end{caml_example*}
+has type
+\caml
+\:module N = P
+\endcaml
+
+Type-level module aliases are used when checking module path
+equalities. That is, in a context where module name @N@ is known to be
+an alias for @P@, not only these two module paths check as equal, but
+@F(N)@ and @F(P)@ are also recognized as equal. In the default
+compilation mode, this is the only difference with the previous
+approach of module aliases having just the same module type as the
+module they reference.
+
+When the compiler flag @'-no-alias-deps'@ is enabled, type-level
+module aliases are also exploited to avoid introducing dependencies
+between compilation units. Namely, a module alias referring to a
+module inside another compilation unit does not introduce a link-time
+dependency on that compilation unit, as long as it is not
+dereferenced; it still introduces a compile-time dependency if the
+interface needs to be read, {\em i.e.} if the module is a submodule
+of the compilation unit, or if some type components are referred to.
+Additionally, accessing a module alias introduces a link-time
+dependency on the compilation unit containing the module referenced by
+the alias, rather than the compilation unit containing the alias.
+Note that these differences in link-time behavior may be incompatible
+with the previous behavior, as some compilation units might not be
+extracted from libraries, and their side-effects ignored.
+
+These weakened dependencies make possible to use module aliases in
+place of the @'-pack'@ mechanism. Suppose that you have a library
+@'Mylib'@ composed of modules @'A'@ and @'B'@. Using @'-pack'@, one
+would issue the command line
+\begin{verbatim}
+ ocamlc -pack a.cmo b.cmo -o mylib.cmo
+\end{verbatim}
+and as a result obtain a @'Mylib'@ compilation unit, containing
+physically @'A'@ and @'B'@ as submodules, and with no dependencies on
+their respective compilation units.
+Here is a concrete example of a possible alternative approach:
+\begin{enumerate}
+\item Rename the files containing @'A'@ and @'B'@ to @'Mylib__A'@ and
+ @'Mylib__B'@.
+\item Create a packing interface @'Mylib.ml'@, containing the
+ following lines.
+\begin{verbatim}
+ module A = Mylib__A
+ module B = Mylib__B
+\end{verbatim}
+\item Compile @'Mylib.ml'@ using @'-no-alias-deps'@, and the other
+ files using @'-no-alias-deps'@ and @'-open' 'Mylib'@ (the last one is
+ equivalent to adding the line @'open!' 'Mylib'@ at the top of each
+ file).
+\begin{verbatim}
+ ocamlc -c -no-alias-deps Mylib.ml
+ ocamlc -c -no-alias-deps -open Mylib Mylib__*.mli Mylib__*.ml
+\end{verbatim}
+\item Finally, create a library containing all the compilation units,
+ and export all the compiled interfaces.
+\begin{verbatim}
+ ocamlc -a Mylib*.cmo -o Mylib.cma
+\end{verbatim}
+\end{enumerate}
+This approach lets you access @'A'@ and @'B'@ directly inside the
+library, and as @'Mylib.A'@ and @'Mylib.B'@ from outside.
+It also has the advantage that @'Mylib'@ is no longer monolithic: if
+you use @'Mylib.A'@, only @'Mylib__A'@ will be linked in, not
+@'Mylib__B'@.
+%Note that in the above @'Mylib.cmo'@ is actually empty, and one could
+%name the interface @'Mylib.mli'@, but this would require that all
+%clients are compiled with the @'-no-alias-deps'@ flag.
+
+Note the use of double underscores in @'Mylib__A'@ and
+@'Mylib__B'@. These were chosen on purpose; the compiler uses the
+following heuristic when printing paths: given a path @'Lib__fooBar'@,
+if @'Lib.FooBar'@ exists and is an alias for @'Lib__fooBar'@, then the
+compiler will always display @'Lib.FooBar'@ instead of
+@'Lib__fooBar'@. This way the long @'Mylib__'@ names stay hidden and
+all the user sees is the nicer dot names. This is how the OCaml
+standard library is compiled.
+
+\section{Overriding in open statements}\label{s:explicit-overriding-open}
+\ikwd{open.\@\texttt{open\char33}}
+
+(Introduced in OCaml 4.01)
+
+\begin{syntax}
+definition:
+ ...
+ | 'open!' module-path
+;
+specification:
+ ...
+ | 'open!' module-path
+;
+expr:
+ ...
+ | 'let' 'open!' module-path 'in' expr
+;
+class-body-type:
+ ...
+ | 'let' 'open!' module-path 'in' class-body-type
+;
+class-expr:
+ ...
+ | 'let' 'open!' module-path 'in' class-expr
+;
+\end{syntax}
+
+Since OCaml 4.01, @"open"@ statements shadowing an existing identifier
+(which is later used) trigger the warning 44. Adding a @"!"@
+character after the @"open"@ keyword indicates that such a shadowing is
+intentional and should not trigger the warning.
+
+This is also available (since OCaml 4.06) for local opens in class
+expressions and class type expressions.
+
+\section{Generalized algebraic datatypes} \ikwd{type\@\texttt{type}}
+\ikwd{match\@\texttt{match}} \label{s:gadts}
+
+(Introduced in OCaml 4.00)
+
+\begin{syntax}
+constr-decl:
+ ...
+ | constr-name ':' [ constr-args '->' ] typexpr
+;
+type-param:
+ ...
+ | [variance] '_'
+\end{syntax}
+
+Generalized algebraic datatypes, or GADTs, extend usual sum types in
+two ways: constraints on type parameters may change depending on the
+value constructor, and some type variables may be existentially
+quantified.
+Adding constraints is done by giving an explicit return type
+(the rightmost @typexpr@ in the above syntax), where type parameters
+are instantiated.
+This return type must use the same type constructor as the type being
+defined, and have the same number of parameters.
+Variables are made existential when they appear inside a constructor's
+argument, but not in its return type.
+
+Since the use of a return type often eliminates the need to name type
+parameters in the left-hand side of a type definition, one can replace
+them with anonymous types @"_"@ in that case.
+
+The constraints associated to each constructor can be recovered
+through pattern-matching.
+Namely, if the type of the scrutinee of a pattern-matching contains
+a locally abstract type, this type can be refined according to the
+constructor used.
+These extra constraints are only valid inside the corresponding branch
+of the pattern-matching.
+If a constructor has some existential variables, fresh locally
+abstract types are generated, and they must not escape the
+scope of this branch.
+
+\paragraph{Recursive functions}
+
+Here is a concrete example:
+\begin{verbatim}
+ type _ term =
+ | Int : int -> int term
+ | Add : (int -> int -> int) term
+ | App : ('b -> 'a) term * 'b term -> 'a term
+
+ let rec eval : type a. a term -> a = function
+ | Int n -> n (* a = int *)
+ | Add -> (fun x y -> x+y) (* a = int -> int -> int *)
+ | App(f,x) -> (eval f) (eval x)
+ (* eval called at types (b->a) and b for fresh b *)
+
+ let two = eval (App (App (Add, Int 1), Int 1))
+ val two : int = 2
+\end{verbatim}
+It is important to remark that the function "eval" is using the
+polymorphic syntax for locally abstract types. When defining a recursive
+function that manipulates a GADT, explicit polymorphic recursion should
+generally be used. For instance, the following definition fails with a
+type error:
+\begin{verbatim}
+ let rec eval (type a) : a term -> a = function
+ | Int n -> n
+ | Add -> (fun x y -> x+y)
+ | App(f,x) -> (eval f) (eval x)
+(* ^
+ Error: This expression has type ($App_'b -> a) term but an expression was
+ expected of type 'a
+ The type constructor $App_'b would escape its scope
+*)
+\end{verbatim}
+In absence of an explicit polymorphic annotation, a monomorphic type
+is inferred for the recursive function. If a recursive call occurs
+inside the function definition at a type that involves an existential
+GADT type variable, this variable flows to the type of the recursive
+function, and thus escapes its scope. In the above example, this happens
+in the branch "App(f,x)" when "eval" is called with "f" as an argument.
+In this branch, the type of "f" is "($App_ 'b-> a)". The prefix "$" in
+"$App_ 'b" denotes an existential type named by the compiler
+(see~\ref{p:existential-names}). Since the type of "eval" is
+"'a term -> 'a", the call "eval f" makes the existential type "$App_'b"
+flow to the type variable "'a" and escape its scope. This triggers the
+above error.
+
+\paragraph{Type inference}
+
+Type inference for GADTs is notoriously hard.
+This is due to the fact some types may become ambiguous when escaping
+from a branch.
+For instance, in the "Int" case above, "n" could have either type "int"
+or "a", and they are not equivalent outside of that branch.
+As a first approximation, type inference will always work if a
+pattern-matching is annotated with types containing no free type
+variables (both on the scrutinee and the return type).
+This is the case in the above example, thanks to the type annotation
+containing only locally abstract types.
+
+In practice, type inference is a bit more clever than that: type
+annotations do not need to be immediately on the pattern-matching, and
+the types do not have to be always closed.
+As a result, it is usually enough to only annotate functions, as in
+the example above. Type annotations are
+propagated in two ways: for the scrutinee, they follow the flow of
+type inference, in a way similar to polymorphic methods; for the
+return type, they follow the structure of the program, they are split
+on functions, propagated to all branches of a pattern matching,
+and go through tuples, records, and sum types.
+Moreover, the notion of ambiguity used is stronger: a type is only
+seen as ambiguous if it was mixed with incompatible types (equated by
+constraints), without type annotations between them.
+For instance, the following program types correctly.
+\begin{verbatim}
+ let rec sum : type a. a term -> _ = fun x ->
+ let y =
+ match x with
+ | Int n -> n
+ | Add -> 0
+ | App(f,x) -> sum f + sum x
+ in y + 1
+ val sum : 'a term -> int = <fun>
+\end{verbatim}
+Here the return type "int" is never mixed with "a", so it is seen as
+non-ambiguous, and can be inferred.
+When using such partial type annotations we strongly suggest
+specifying the "-principal" mode, to check that inference is
+principal.
+
+The exhaustiveness check is aware of GADT constraints, and can
+automatically infer that some cases cannot happen.
+For instance, the following pattern matching is correctly seen as
+exhaustive (the "Add" case cannot happen).
+\begin{verbatim}
+ let get_int : int term -> int = function
+ | Int n -> n
+ | App(_,_) -> 0
+\end{verbatim}
+
+
+\paragraph{Refutation cases} (Introduced in OCaml 4.03)
+
+Usually, the exhaustiveness check only tries to check whether the
+cases omitted from the pattern matching are typable or not.
+However, you can force it to try harder by adding {\em refutation cases}:
+\begin{syntax}
+matching-case:
+ pattern ['when' expr] '->' expr
+ | pattern '->' '.'
+\end{syntax}
+In presence of a refutation case, the exhaustiveness check will first
+compute the intersection of the pattern with the complement of the
+cases preceding it. It then checks whether the resulting patterns can
+really match any concrete values by trying to type-check them.
+Wild cards in the generated patterns are handled in a special way: if
+their type is a variant type with only GADT constructors, then the
+pattern is split into the different constructors, in order to check whether
+any of them is possible (this splitting is not done for arguments of these
+constructors, to avoid non-termination). We also split tuples and
+variant types with only one case, since they may contain GADTs inside.
+For instance, the following code is deemed exhaustive:
+
+\begin{verbatim}
+ type _ t =
+ | Int : int t
+ | Bool : bool t
+
+ let deep : (char t * int) option -> char = function
+ | None -> 'c'
+ | _ -> .
+\end{verbatim}
+
+Namely, the inferred remaining case is "Some _", which is split into
+"Some (Int, _)" and "Some (Bool, _)", which are both untypable because
+"deep" expects a non-existing "char t" as the first element of the tuple.
+Note that the refutation case could be omitted here, because it is
+automatically added when there is only one case in the pattern
+matching.
+
+Another addition is that the redundancy check is now aware of GADTs: a
+case will be detected as redundant if it could be replaced by a
+refutation case using the same pattern.
+
+\paragraph{Advanced examples}
+The "term" type we have defined above is an {\em indexed} type, where
+a type parameter reflects a property of the value contents.
+Another use of GADTs is {\em singleton} types, where a GADT value
+represents exactly one type. This value can be used as runtime
+representation for this type, and a function receiving it can have a
+polytypic behavior.
+
+Here is an example of a polymorphic function that takes the
+runtime representation of some type "t" and a value of the same type,
+then pretty-prints the value as a string:
+\begin{verbatim}
+ type _ typ =
+ | Int : int typ
+ | String : string typ
+ | Pair : 'a typ * 'b typ -> ('a * 'b) typ
+
+ let rec to_string: type t. t typ -> t -> string =
+ fun t x ->
+ match t with
+ | Int -> string_of_int x
+ | String -> Printf.sprintf "%S" x
+ | Pair(t1,t2) ->
+ let (x1, x2) = x in
+ Printf.sprintf "(%s,%s)" (to_string t1 x1) (to_string t2 x2)
+\end{verbatim}
+
+Another frequent application of GADTs is equality witnesses.
+\begin{verbatim}
+ type (_,_) eq = Eq : ('a,'a) eq
+
+ let cast : type a b. (a,b) eq -> a -> b = fun Eq x -> x
+\end{verbatim}
+Here type "eq" has only one constructor, and by matching on it one
+adds a local constraint allowing the conversion between "a" and "b".
+By building such equality witnesses, one can make equal types which
+are syntactically different.
+
+Here is an example using both singleton types and equality witnesses
+to implement dynamic types.
+\begin{verbatim}
+ let rec eq_type : type a b. a typ -> b typ -> (a,b) eq option =
+ fun a b ->
+ match a, b with
+ | Int, Int -> Some Eq
+ | String, String -> Some Eq
+ | Pair(a1,a2), Pair(b1,b2) ->
+ begin match eq_type a1 b1, eq_type a2 b2 with
+ | Some Eq, Some Eq -> Some Eq
+ | _ -> None
+ end
+ | _ -> None
+
+ type dyn = Dyn : 'a typ * 'a -> dyn
+
+ let get_dyn : type a. a typ -> dyn -> a option =
+ fun a (Dyn(b,x)) ->
+ match eq_type a b with
+ | None -> None
+ | Some Eq -> Some x
+\end{verbatim}
+
+\paragraph{Existential type names in error messages}%
+\label{p:existential-names}
+(Updated in OCaml 4.03.0)
+
+The typing of pattern matching in presence of GADT can generate many
+existential types. When necessary, error messages refer to these
+existential types using compiler-generated names. Currently, the
+compiler generates these names according to the following nomenclature:
+\begin{itemize}
+\item First, types whose name starts with a "$" are existentials.
+\item "$Constr_'a" denotes an existential type introduced for the type
+variable "'a" of the GADT constructor "Constr":
+\begin{caml_example}{verbatim}[error]
+type any = Any : 'name -> any
+let escape (Any x) = x
+\end{caml_example}
+\item "$Constr" denotes an existential type introduced for an anonymous %$
+type variable in the GADT constructor "Constr":
+\begin{caml_example}{verbatim}[error]
+type any = Any : _ -> any
+let escape (Any x) = x
+\end{caml_example}
+\item "$'a" if the existential variable was unified with the type %$
+variable "'a" during typing:
+\begin{caml_example}{verbatim}[error]
+type ('arg,'result,'aux) fn =
+ | Fun: ('a ->'b) -> ('a,'b,unit) fn
+ | Mem1: ('a ->'b) * 'a * 'b -> ('a, 'b, 'a * 'b) fn
+ let apply: ('arg,'result, _ ) fn -> 'arg -> 'result = fun f x ->
+ match f with
+ | Fun f -> f x
+ | Mem1 (f,y,fy) -> if x = y then fy else f x
+\end{caml_example}
+\item "$n" (n a number) is an internally generated existential %$
+which could not be named using one of the previous schemes.
+\end{itemize}
+
+As shown by the last item, the current behavior is imperfect
+and may be improved in future versions.
+
+\paragraph{Equations on non-local abstract types} (Introduced in OCaml
+4.04)
+
+GADT pattern-matching may also add type equations to non-local
+abstract types. The behaviour is the same as with local abstract
+types. Reusing the above "eq" type, one can write:
+\begin{verbatim}
+ module M : sig type t val x : t val e : (t,int) eq end = struct
+ type t = int
+ let x = 33
+ let e = Eq
+ end
+
+ let x : int = let Eq = M.e in M.x
+\end{verbatim}
+
+Of course, not all abstract types can be refined, as this would
+contradict the exhaustiveness check. Namely, builtin types (those
+defined by the compiler itself, such as "int" or "array"), and
+abstract types defined by the local module, are non-instantiable, and
+as such cause a type error rather than introduce an equation.
+
+\section{Syntax for Bigarray access}\label{s:bigarray-access}
+
+(Introduced in Objective Caml 3.00)
+
+\begin{syntax}
+expr:
+ ...
+ | expr '.{' expr { ',' expr } '}'
+ | expr '.{' expr { ',' expr } '}' '<-' expr
+\end{syntax}
+
+This extension provides syntactic sugar for getting and setting
+elements in the arrays provided by the
+"Bigarray"[\moduleref{Bigarray}] library.
+
+The short expressions are translated into calls to functions of the
+"Bigarray" module as described in the following table.
+
+\begin{tableau}{|l|l|}{expression}{translation}
+\entree{@expr_0'.{'expr_1'}'@}
+ {"Bigarray.Array1.get "@expr_0 expr_1@}
+\entree{@expr_0'.{'expr_1'}' '<-'expr@}
+ {"Bigarray.Array1.set "@expr_0 expr_1 expr@}
+\entree{@expr_0'.{'expr_1',' expr_2'}'@}
+ {"Bigarray.Array2.get "@expr_0 expr_1 expr_2@}
+\entree{@expr_0'.{'expr_1',' expr_2'}' '<-'expr@}
+ {"Bigarray.Array2.set "@expr_0 expr_1 expr_2 expr@}
+\entree{@expr_0'.{'expr_1',' expr_2',' expr_3'}'@}
+ {"Bigarray.Array3.get "@expr_0 expr_1 expr_2 expr_3@}
+\entree{@expr_0'.{'expr_1',' expr_2',' expr_3'}' '<-'expr@}
+ {"Bigarray.Array3.set "@expr_0 expr_1 expr_2 expr_3 expr@}
+\entree{@expr_0'.{'expr_1',' \ldots',' expr_n'}'@}
+ {"Bigarray.Genarray.get "@ expr_0 '[|' expr_1',' \ldots ','
+ expr_n '|]'@}
+\entree{@expr_0'.{'expr_1',' \ldots',' expr_n'}' '<-'expr@}
+ {"Bigarray.Genarray.set "@ expr_0 '[|' expr_1',' \ldots ','
+ expr_n '|]' expr@}
+\end{tableau}
+
+The last two entries are valid for any $n > 3$.
+
+\section{Attributes}\label{s:attributes}
+
+\ikwd{when\@\texttt{when}}
+
+(Introduced in OCaml 4.02,
+infix notations for constructs other than expressions added in 4.03)
+
+Attributes are ``decorations'' of the syntax tree which are mostly
+ignored by the type-checker but can be used by external tools. An
+attribute is made of an identifier and a payload, which can be a
+structure, a type expression (prefixed with ":"), a signature
+(prefixed with ":") or a pattern (prefixed with "?") optionally
+followed by a "when" clause:
+
+
+\begin{syntax}
+attr-id:
+ lowercase-ident
+ | capitalized-ident
+ | attr-id '.' attr-id
+;
+attr-payload:
+ [ module-items ]
+ | ':' typexpr
+ | ':' [ specification ]
+ | '?' pattern ['when' expr]
+;
+\end{syntax}
+
+The first form of attributes is attached with a postfix notation on
+``algebraic'' categories:
+
+\begin{syntax}
+attribute:
+ '[@' attr-id attr-payload ']'
+;
+expr: ...
+ | expr attribute
+;
+typexpr: ...
+ | typexpr attribute
+;
+pattern: ...
+ | pattern attribute
+;
+module-expr: ...
+ | module-expr attribute
+;
+module-type: ...
+ | module-type attribute
+;
+class-expr: ...
+ | class-expr attribute
+;
+class-type: ...
+ | class-type attribute
+;
+\end{syntax}
+
+This form of attributes can also be inserted after the @'`'tag-name@
+in polymorphic variant type expressions (@tag-spec-first@, @tag-spec@,
+@tag-spec-full@) or after the @method-name@ in @method-type@.
+
+The same syntactic form is also used to attach attributes to labels and
+constructors in type declarations:
+
+\begin{syntax}
+field-decl:
+ ['mutable'] field-name ':' poly-typexpr {attribute}
+;
+constr-decl:
+ (constr-name || '()') [ 'of' constr-args ] {attribute}
+;
+\end{syntax}
+
+Note: when a label declaration is followed by a semi-colon, attributes
+can also be put after the semi-colon (in which case they are merged to
+those specified before).
+
+
+The second form of attributes are attached to ``blocks'' such as type
+declarations, class fields, etc:
+
+\begin{syntax}
+item-attribute:
+ '[@@' attr-id attr-payload ']'
+;
+typedef: ...
+ | typedef item-attribute
+;
+exception-definition:
+ 'exception' constr-decl
+ | 'exception' constr-name '=' constr
+;
+module-items:
+ [';;'] ( definition || expr { item-attribute } ) { [';;'] definition || ';;' expr { item-attribute } } [';;']
+;
+class-binding: ...
+ | class-binding item-attribute
+;
+class-spec: ...
+ | class-spec item-attribute
+;
+classtype-def: ...
+ | classtype-def item-attribute
+;
+definition:
+ 'let' ['rec'] let-binding { 'and' let-binding }
+ | 'external' value-name ':' typexpr '=' external-declaration { item-attribute }
+ | type-definition
+ | exception-definition { item-attribute }
+ | class-definition
+ | classtype-definition
+ | 'module' module-name { '(' module-name ':' module-type ')' }
+ [ ':' module-type ] \\ '=' module-expr { item-attribute }
+ | 'module' 'type' modtype-name '=' module-type { item-attribute }
+ | 'open' module-path { item-attribute }
+ | 'include' module-expr { item-attribute }
+ | 'module' 'rec' module-name ':' module-type '=' \\
+ module-expr { item-attribute } \\
+ { 'and' module-name ':' module-type '=' module-expr \\
+ { item-attribute } }
+;
+specification:
+ 'val' value-name ':' typexpr { item-attribute }
+ | 'external' value-name ':' typexpr '=' external-declaration { item-attribute }
+ | type-definition
+ | 'exception' constr-decl { item-attribute }
+ | class-specification
+ | classtype-definition
+ | 'module' module-name ':' module-type { item-attribute }
+ | 'module' module-name { '(' module-name ':' module-type ')' }
+ ':' module-type { item-attribute }
+ | 'module' 'type' modtype-name { item-attribute }
+ | 'module' 'type' modtype-name '=' module-type { item-attribute }
+ | 'open' module-path { item-attribute }
+ | 'include' module-type { item-attribute }
+;
+class-field-spec: ...
+ | class-field-spec item-attribute
+;
+class-field: ...
+ | class-field item-attribute
+;
+\end{syntax}
+
+A third form of attributes appears as stand-alone structure or
+signature items in the module or class sub-languages. They are not
+attached to any specific node in the syntax tree:
+
+\begin{syntax}
+floating-attribute:
+ '[@@@' attr-id attr-payload ']'
+;
+definition: ...
+ | floating-attribute
+;
+specification: ...
+ | floating-attribute
+;
+class-field-spec: ...
+ | floating-attribute
+;
+class-field: ...
+ | floating-attribute
+;
+\end{syntax}
+
+(Note: contrary to what the grammar above describes, @item-attributes@
+cannot be attached to these floating attributes in @class-field-spec@
+and @class-field@.)
+
+
+It is also possible to specify attributes using an infix syntax. For instance:
+
+\begin{verbatim}
+let[@foo] x = 2 in x + 1 === (let x = 2 [@@foo] in x + 1)
+begin[@foo][@bar x] ... end === (begin ... end)[@foo][@@bar x]
+module[@foo] M = ... === module M = ... [@@foo]
+type[@foo] t = T === type t = T [@@foo]
+method[@foo] m = ... === method m = ... [@@foo]
+\end{verbatim}
+
+For "let", the attributes are applied to each bindings:
+
+\begin{verbatim}
+let[@foo] x = 2 and y = 3 in x + y === (let x = 2 [@@foo] and y = 3 in x + y)
+let[@foo] x = 2
+and[@bar] y = 3 in x + y === (let x = 2 [@@foo] and y = 3 [@bar] in x + y)
+\end{verbatim}
+
+
+\subsection{Built-in attributes}
+\label{ss:builtin-attributes}
+
+Some attributes are understood by the type-checker:
+\begin{itemize}
+\item
+ ``ocaml.warning'' or ``warning'', with a string literal payload.
+ This can be used as floating attributes in a
+ signature/structure/object/object type. The string is parsed and has
+ the same effect as the "-w" command-line option, in the scope between
+ the attribute and the end of the current
+ signature/structure/object/object type. The attribute can also be
+ attached to any kind of syntactic item which support attributes
+ (such as an expression, or a type expression)
+ in which case its scope is limited to that item.
+ Note that it is not well-defined which scope is used for a specific
+ warning. This is implementation dependant and can change between versions.
+ Some warnings are even completely outside the control of ``ocaml.warning''
+ (for instance, warnings 1, 2, 14, 29 and 50).
+
+\item
+ ``ocaml.warnerror'' or ``warnerror'', with a string literal payload.
+ Same as ``ocaml.warning'', for the "-warn-error" command-line option.
+\item
+ ``ocaml.deprecated'' or ``deprecated''.
+ Can be applied to most kind of items in signatures or
+ structures. When the element is later referenced, a warning (3) is
+ triggered. If the payload of the attribute is a string literal,
+ the warning message includes this text. It is also possible
+ to use this ``ocaml.deprecated'' as a floating attribute
+ on top of an ``.mli'' file (i.e. before any other non-attribute
+ item) or on top of an ``.ml'' file without a corresponding
+ interface; this marks the unit itself as being deprecated.
+\item
+ ``ocaml.deprecated_mutable'' or ``deprecated_mutable''.
+ Can be applied to a mutable record label. If the label is later
+ used to modify the field (with ``expr.l <- expr''), a warning (3)
+ will be triggered. If the payload of the attribute is a string literal,
+ the warning message includes this text.
+\item
+ ``ocaml.ppwarning'' or ``ppwarning'', in any context, with
+ a string literal payload. The text is reported as warning (22)
+ by the compiler (currently, the warning location is the location
+ of the string payload). This is mostly useful for preprocessors which
+ need to communicate warnings to the user. This could also be used
+ to mark explicitly some code location for further inspection.
+\item
+ ``ocaml.warn_on_literal_pattern'' or ``warn_on_literal_pattern'' annotate
+ constructors in type definition. A warning (52) is then emitted when this
+ constructor is pattern matched with a constant literal as argument. This
+ attribute denotes constructors whose argument is purely informative and
+ may change in the future. Therefore, pattern matching on this argument
+ with a constant literal is unreliable. For instance, all built-in exception
+ constructors are marked as ``warn_on_literal_pattern''.
+ Note that, due to an implementation limitation, this warning (52) is only
+ triggered for single argument constructor.
+\item
+ ``ocaml.tailcall'' or ``tailcall'' can be applied to function
+ application in order to check that the call is tailcall optimized.
+ If it it not the case, a warning (51) is emitted.
+\item
+ ``ocaml.inline'' or ``inline'' take either ``never'', ``always''
+ or nothing as payload on a function or functor definition. If no payload
+ is provided, the default value is ``always''. This payload controls when
+ applications of the annotated functions should be inlined.
+\item
+ ``ocaml.inlined'' or ``inlined'' can be applied to any function or functor
+ application to check that the call is inlined by the compiler. If the call
+ is not inlined, a warning (55) is emitted.
+\item
+ ``ocaml.noalloc'', ``ocaml.unboxed''and ``ocaml.untagged'' or
+ ``noalloc'', ``unboxed'' and ``untagged'' can be used on external
+ definitions to obtain finer control over the C-to-OCaml interface. See
+ \ref{s:C-cheaper-call} for more details.
+\item
+ ``ocaml.immediate'' or ``immediate'' applied on an abstract type mark the type as
+ having a non-pointer implementation (e.g. ``int'', ``bool'', ``char'' or
+ enumerated types). Mutation of these immediate types does not activate the
+ garbage collector's write barrier, which can significantly boost performance in
+ programs relying heavily on mutable state.
+\item
+ "ocaml.unboxed" or "unboxed" can be used on a type definition if the
+ type is a single-field record or a concrete type with a single
+ constructor that has a single argument. It tells the compiler to
+ optimize the representation of the type by removing the block that
+ represents the record or the constructor (i.e. a value of this type
+ is physically equal to its argument). In the case of GADTs, an
+ additional restriction applies: the argument must not be an
+ existential variable, represented by an existential type variable,
+ or an abstract type constructor applied to an existential type
+ variable.
+\item
+ "ocaml.boxed" or "boxed" can be used on type definitions to mean
+ the opposite of "ocaml.unboxed": keep the unoptimized
+ representation of the type. When there is no annotation, the
+ default is currently "boxed" but it may change in the future.
+\end{itemize}
+
+\begin{verbatim}
+module X = struct
+ [@@@warning "+9"] (* locally enable warning 9 in this structure *)
+ ...
+end
+ [@@deprecated "Please use module 'Y' instead."]
+
+let x = begin[@warning "+9"] ... end in ....
+
+type t = A | B
+ [@@deprecated "Please use type 's' instead."]
+
+let f x =
+ assert (x >= 0) [@ppwarning "TODO: remove this later"];
+
+let rec no_op = function
+ | [] -> ()
+ | _ :: q -> (no_op[@tailcall]) q;;
+
+let f x = x [@@inline]
+
+let () = (f[@inlined]) ()
+
+type fragile =
+ | Int of int [@warn_on_literal_pattern]
+ | String of string [@warn_on_literal_pattern]
+
+let f = function
+| Int 0 | String "constant" -> () (* trigger warning 52 *)
+| _ -> ()
+
+module Immediate: sig
+ type t [@@immediate]
+ val x: t ref
+end = struct
+ type t = A | B
+ let x = ref 0
+end
+ ....
+
+\end{verbatim}
+
+
+\section{Extension nodes}\label{s:extension-nodes}
+
+(Introduced in OCaml 4.02,
+infix notations for constructs other than expressions added in 4.03,
+infix notation (e1 ;\%ext e2) added in 4.04.
+)
+
+Extension nodes are generic placeholders in the syntax tree. They are
+rejected by the type-checker and are intended to be ``expanded'' by external
+tools such as "-ppx" rewriters.
+
+Extension nodes share the same notion of identifier and payload as
+attributes~\ref{s:attributes}.
+
+The first form of extension node is used for ``algebraic'' categories:
+
+\begin{syntax}
+extension:
+ '[%' attr-id attr-payload ']'
+;
+expr: ...
+ | extension
+;
+typexpr: ...
+ | extension
+;
+pattern: ...
+ | extension
+;
+module-expr: ...
+ | extension
+;
+module-type: ...
+ | extension
+;
+class-expr: ...
+ | extension
+;
+class-type: ...
+ | extension
+;
+\end{syntax}
+
+A second form of extension node can be used in structures and
+signatures, both in the module and object languages:
+
+\begin{syntax}
+item-extension:
+ '[%%' attr-id attr-payload ']'
+;
+definition: ...
+ | item-extension
+;
+specification: ...
+ | item-extension
+;
+class-field-spec: ...
+ | item-extension
+;
+class-field: ...
+ | item-extension
+;
+\end{syntax}
+
+An infix form is available for extension nodes when
+the payload is of the same kind
+(expression with expression, pattern with pattern ...).
+
+Examples:
+
+\begin{verbatim}
+let%foo x = 2 in x + 1 === [%foo let x = 2 in x + 1]
+begin%foo ... end === [%foo begin ... end]
+x ;%foo 2 === [%foo x; 2]
+module%foo M = .. === [%%foo module M = ... ]
+val%foo x : t === [%%foo: val x : t]
+\end{verbatim}
+
+When this form is used together with the infix syntax for attributes,
+the attributes are considered to apply to the payload:
+
+\begin{verbatim}
+fun%foo[@bar] x -> x + 1 === [%foo (fun x -> x + 1)[@bar ] ];
+\end{verbatim}
+
+\subsection{Built-in extension nodes}
+
+(Introduced in OCaml 4.03)
+
+Some extension nodes are understood by the compiler itself:
+\begin{itemize}
+ \item
+ ``ocaml.extension_constructor'' or ``extension_constructor''
+ take as payload a constructor from an extensible variant type
+ (see \ref{s:extensible-variants}) and return its extension
+ constructor slot.
+\end{itemize}
+
+\begin{caml_example*}{verbatim}
+type t = ..
+type t += X of int | Y of string
+let x = [%extension_constructor X]
+let y = [%extension_constructor Y]
+\end{caml_example*}
+\begin{caml_example}{toplevel}
+ x <> y;;
+\end{caml_example}
+
+\section{Quoted strings}\label{s:quoted-strings}
+
+(Introduced in OCaml 4.02)
+
+Quoted strings "{foo|...|foo}" provide a different lexical syntax to
+write string literals in OCaml code. They are useful to represent
+strings of arbitrary content without escaping -- as long as the
+delimiter you chose (here "|foo}") does not occur in the string
+itself.
+
+\begin{syntax}
+string-literal: ...
+ | '{' quoted-string-id '|' ........ '|' quoted-string-id '}'
+;
+quoted-string-id:
+ { 'a'...'z' || '_' }
+;
+\end{syntax}
+
+The opening delimiter has the form "{id|" where "id" is a (possibly
+empty) sequence of lowercase letters and underscores. The
+corresponding closing delimiter is "|id}" (with the same
+identifier). Unlike regular OCaml string literals, quoted
+strings do not interpret any character in a special way.
+
+Example:
+
+\begin{verbatim}
+String.length {|\"|} (* returns 2 *)
+String.length {foo|\"|foo} (* returns 2 *)
+\end{verbatim}
+
+Quoted strings are interesting in particular in conjunction to
+extension nodes "[%foo ...]" (see \ref{s:extension-nodes}) to embed
+foreign syntax fragments to be interpreted by a preprocessor and
+turned into OCaml code: you can use "[%sql {|...|}]" for example to
+represent arbitrary SQL statements -- assuming you have a ppx-rewriter
+that recognizes the "%sql" extension -- without requiring escaping
+quotes.
+
+Note that the non-extension form, for example "{sql|...|sql}", should
+not be used for this purpose, as the user cannot see in the code that
+this string literal has a different semantics than they expect, and
+giving a semantics to a specific delimiter limits the freedom to
+change the delimiter to avoid escaping issues.
+
+\section{Exception cases in pattern matching}\label{s:exception-match}
+
+(Introduced in OCaml 4.02)
+
+A new form of exception patterns is allowed, only as a toplevel
+pattern under a "match"..."with" pattern-matching (other occurrences
+are rejected by the type-checker).
+
+\begin{syntax}
+pattern: ...
+ | 'exception' pattern
+;
+\end{syntax}
+
+Cases with such a toplevel pattern are called ``exception cases'',
+as opposed to regular ``value cases''. Exception cases are applied
+when the evaluation of the matched expression raises an exception.
+The exception value is then matched against all the exception cases
+and re-raised if none of them accept the exception (as for a
+"try"..."with" block). Since the bodies of all exception and value
+cases is outside the scope of the exception handler, they are all
+considered to be in tail-position: if the "match"..."with" block
+itself is in tail position in the current function, any function call
+in tail position in one of the case bodies results in an actual tail
+call.
+
+It is an error if all cases are exception cases in a given pattern
+matching.
+
+\section{Extensible variant types}\label{s:extensible-variants}
+
+(Introduced in OCaml 4.02)
+
+\begin{syntax}
+type-representation:
+ ...
+ | '=' '..'
+;
+specification:
+ ...
+ | 'type' [type-params] typeconstr type-extension-spec
+;
+definition:
+ ...
+ | 'type' [type-params] typeconstr type-extension-def
+;
+type-extension-spec: '+=' ['private'] ['|'] constr-decl { '|' constr-decl }
+;
+type-extension-def: '+=' ['private'] ['|'] constr-def { '|' constr-def }
+;
+constr-def:
+ constr-decl
+ | constr-name '=' constr
+;
+\end{syntax}
+
+Extensible variant types are variant types which can be extended with
+new variant constructors. Extensible variant types are defined using
+"..". New variant constructors are added using "+=".
+\begin{verbatim}
+ type attr = ..
+
+ type attr += Str of string
+
+ type attr +=
+ | Int of int
+ | Float of float
+\end{verbatim}
+
+Pattern matching on an extensible variant type requires a default case
+to handle unknown variant constructors:
+\begin{verbatim}
+ let to_string = function
+ | Str s -> s
+ | Int i -> string_of_int i
+ | Float f -> string_of_float f
+ | _ -> "?"
+\end{verbatim}
+
+A preexisting example of an extensible variant type is the built-in
+"exn" type used for exceptions. Indeed, exception constructors can be
+declared using the type extension syntax:
+\begin{verbatim}
+ type exn += Exc of int
+\end{verbatim}
+
+Extensible variant constructors can be rebound to a different name. This
+allows exporting variants from another module.
+\begin{verbatim}
+ type Expr.attr += Str = Expr.Str
+\end{verbatim}
+
+Extensible variant constructors can be declared "private". As with
+regular variants, this prevents them from being constructed directly by
+constructor application while still allowing them to be de-structured in
+pattern-matching.
+\begin{verbatim}
+ module Bool : sig
+ type attr += private Bool of int
+ val bool : bool -> attr
+ end = struct
+ type attr += Bool of int
+ let bool p = if p then Bool 1 else Bool 0
+ end
+\end{verbatim}
+
+\subsection{Private extensible variant types}
+
+(Introduced in OCaml 4.06)
+
+\begin{syntax}
+type-representation:
+ ...
+ | '=' 'private' '..'
+;
+\end{syntax}
+
+Extensible variant types can be declared "private". This prevents new
+constructors from being declared directly, but allows extension
+constructors to be referred to in interfaces.
+\begin{verbatim}
+ module Msg : sig
+ type t = private ..
+ module MkConstr (X : sig type t end) : sig
+ type t += C of X.t
+ end
+ end = struct
+ type t = ..
+ module MkConstr (X : sig type t end) = struct
+ type t += C of X.t
+ end
+ end
+\end{verbatim}
+
+\section{Generative functors}\label{s:generative-functors}
+
+(Introduced in OCaml 4.02)
+
+\begin{syntax}
+module-expr:
+ ...
+ | 'functor' '()' '->' module-expr
+ | module-expr '()'
+;
+definition:
+ ...
+ | 'module' module-name { '(' module-name ':' module-type ')' || '()' }
+ [ ':' module-type ] \\ '=' module-expr
+;
+module-type:
+ ...
+ | 'functor' '()' '->' module-type
+;
+specification:
+ ...
+ | 'module' module-name { '(' module-name ':' module-type ')' || '()' }
+ ':' module-type
+;
+\end{syntax}
+
+A generative functor takes a unit "()" argument.
+In order to use it, one must necessarily apply it to this unit argument,
+ensuring that all type components in the result of the functor behave
+in a generative way, {\em i.e.} they are different from types obtained
+by other applications of the same functor.
+This is equivalent to taking an argument of signature "sig end", and always
+applying to "struct end", but not to some defined module (in the
+latter case, applying twice to the same module would return identical
+types).
+
+As a side-effect of this generativity, one is allowed to unpack
+first-class modules in the body of generative functors.
+
+\section{Extension-only syntax}
+(Introduced in OCaml 4.02.2, extended in 4.03)
+
+Some syntactic constructions are accepted during parsing and rejected
+during type checking. These syntactic constructions can therefore not
+be used directly in vanilla OCaml. However, "-ppx" rewriters and other
+external tools can exploit this parser leniency to extend the language
+with these new syntactic constructions by rewriting them to
+vanilla constructions.
+\subsection{Extension operators} \label{s:ext-ops}
+(Introduced in OCaml 4.02.2)
+\begin{syntax}
+infix-symbol:
+ ...
+ | "#" {operator-chars} "#" {operator-char '|' "#"}
+;
+\end{syntax}
+
+Operator names starting with a "#" character and containing more than
+one "#" character are reserved for extensions.
+
+\subsection{Extension literals} \label{s:extension-literals}
+(Introduced in OCaml 4.03)
+\begin{syntax}
+float-literal:
+ ...
+ | ["-"] ("0"\ldots"9") { "0"\ldots"9"||"_" } ["." { "0"\ldots"9"||"_" }]
+ [("e"||"E") ["+"||"-"] ("0"\ldots"9") { "0"\ldots"9"||"_" }]
+ ["g"\ldots"z"||"G"\ldots"Z"]
+ | ["-"] ("0x"||"0X")
+ ("0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f")
+ { "0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f"||"_" }\\
+ ["." { "0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f"||"_" }]
+ [("p"||"P") ["+"||"-"] ("0"\ldots"9") { "0"\ldots"9"||"_" }]
+ ["g"\ldots"z"||"G"\ldots"Z"]
+;
+int-literal:
+ ...
+ | ["-"] ("0"\ldots"9") { "0"\ldots"9" || "_" }["g"\ldots"z"||"G"\ldots"Z"]
+ | ["-"] ("0x"||"0X") ("0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f")
+ { "0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f"||"_" }
+ ["g"\ldots"z"||"G"\ldots"Z"]
+ | ["-"] ("0o"||"0O") ("0"\ldots"7") { "0"\ldots"7"||"_" }
+ ["g"\ldots"z"||"G"\ldots"Z"]
+ | ["-"] ("0b"||"0B") ("0"\ldots"1") { "0"\ldots"1"||"_" }
+ ["g"\ldots"z"||"G"\ldots"Z"]
+;
+\end{syntax}
+Int and float literals followed by an one-letter identifier in the
+range @["g".."z"||"G".."Z"]@ are extension-only literals.
+
+\section{Inline records} \label{s:inline-records}
+(Introduced in OCaml 4.03)
+\begin{syntax}
+ constr-args:
+ ...
+ | record-decl
+;
+\end{syntax}
+
+The arguments of a sum-type constructors can now be defined using the
+same syntax as records. Mutable and polymorphic fields are allowed.
+GADT syntax is supported. Attributes can be specified on individual
+fields.
+
+Syntactically, building or matching constructors with such an inline
+record argument is similar to working with a unary constructor whose
+unique argument is a declared record type. A pattern can bind
+the inline record as a pseudo-value, but the record cannot escape the
+scope of the binding and can only be used with the dot-notation to
+extract or modify fields or to build new constructor values.
+
+\begin{verbatim}
+type t =
+ | Point of {width: int; mutable x: float; mutable y: float}
+ | ...
+
+let v = Point {width = 10; x = 0.; y = 0.}
+
+let scale l = function
+ | Point p -> Point {p with x = l *. p.x; y = l *. p.y}
+ | ....
+
+let print = function
+ | Point {x; y; _} -> Printf.printf "%f/%f" x y
+ | ....
+
+let reset = function
+ | Point p -> p.x <- 0.; p.y <- 0.
+ | ...
+
+let invalid = function
+ | Point p -> p (* INVALID *)
+ | ...
+\end{verbatim}
+
+
+\section{Local exceptions}
+\ikwd{let\@\texttt{let}}
+\ikwd{exception\@\texttt{exception}} \label{s:local-exceptions}
+
+(Introduced in OCaml 4.04)
+
+It is possible to define local exceptions in expressions:
+
+\begin{syntax}
+expr:
+ ...
+ | "let" "exception" constr-decl "in" expr
+\end{syntax}
+
+
+The syntactic scope of the exception constructor is the inner
+expression, but nothing prevents exception values created with this
+constructor from escaping this scope. Two executions of the definition
+above result in two incompatible exception constructors (as for any
+exception definition).
+
+
+\section{Documentation comments}
+(Introduced in OCaml 4.03)
+
+Comments which start with "**" are treated specially by the
+compiler. They are automatically converted during parsing into
+attributes (see \ref{s:attributes}) to allow tools to process them as
+documentation.
+
+Such comments can take three forms: {\em floating comments}, {\em item
+comments} and {\em label comments}. Any comment starting with "**" which
+does not match one of these forms will cause the compiler to emit
+warning 50.
+
+Comments which start with "**" are also used by the ocamldoc
+documentation generator (see \ref{c:ocamldoc}). The three comment forms
+recognised by the compiler are a subset of the forms accepted by
+ocamldoc (see \ref{s:ocamldoc-comments}).
+
+\subsection{Floating comments}
+
+Comments surrounded by blank lines that appear within structures,
+signatures, classes or class types are converted into
+@floating-attribute@s. For example:
+
+\begin{verbatim}
+type t = T
+
+(** Now some definitions for [t] *)
+
+let mkT = T
+\end{verbatim}
+
+will be converted to:
+
+\begin{verbatim}
+type t = T
+
+[@@@ocaml.text " Now some definitions for [t] "]
+
+let mkT = T
+\end{verbatim}
+
+\subsection{Item comments}
+
+Comments which appear {\em immediately before} or {\em immediately
+after} a structure item, signature item, class item or class type item
+are converted into @item-attribute@s. Immediately before or immediately
+after means that there must be no blank lines, ";;", or other
+documentation comments between them. For example:
+
+\begin{verbatim}
+type t = T
+(** A description of [t] *)
+
+\end{verbatim}
+
+or
+
+\begin{verbatim}
+
+(** A description of [t] *)
+type t = T
+\end{verbatim}
+
+will be converted to:
+
+\begin{verbatim}
+type t = T
+[@@ocaml.doc " A description of [t] "]
+\end{verbatim}
+
+Note that, if a comment appears immediately next to multiple items,
+as in:
+
+\begin{verbatim}
+type t = T
+(** An ambiguous comment *)
+type s = S
+\end{verbatim}
+
+then it will be attached to both items:
+
+\begin{verbatim}
+type t = T
+[@@ocaml.doc " An ambiguous comment "]
+type s = S
+[@@ocaml.doc " An ambiguous comment "]
+\end{verbatim}
+
+and the compiler will emit warning 50.
+
+\subsection{Label comments}
+
+Comments which appear {\em immediately after} a labelled argument,
+record field, variant constructor, object method or polymorphic variant
+constructor are are converted into @attribute@s. Immediately
+after means that there must be no blank lines or other documentation
+comments between them. For example:
+
+\begin{verbatim}
+type t1 = lbl:int (** Labelled argument *) -> unit
+
+type t2 = {
+ fld: int; (** Record field *)
+ fld2: float;
+}
+
+type t3 =
+ | Cstr of string (** Variant constructor *)
+ | Cstr2 of string
+
+type t4 = < meth: int * int; (** Object method *) >
+
+type t5 = [
+ `PCstr (** Polymorphic variant constructor *)
+]
+\end{verbatim}
+
+will be converted to:
+
+\begin{verbatim}
+type t1 = lbl:(int [@ocaml.doc " Labelled argument "]) -> unit
+
+type t2 = {
+ fld: int [@ocaml.doc " Record field "];
+ fld2: float;
+}
+
+type t3 =
+ | Cstr of string [@ocaml.doc " Variant constructor "]
+ | Cstr2 of string
+
+type t4 = < meth : int * int [@ocaml.doc " Object method "] >
+
+type t5 = [
+ `PCstr [@ocaml.doc " Polymorphic variant constructor "]
+]
+\end{verbatim}
+
+Note that label comments take precedence over item comments, so:
+
+\begin{verbatim}
+type t = T of string
+(** Attaches to T not t *)
+\end{verbatim}
+
+will be converted to:
+
+\begin{verbatim}
+type t = T of string [@ocaml.doc " Attaches to T not t "]
+\end{verbatim}
+
+whilst:
+
+\begin{verbatim}
+type t = T of string
+(** Attaches to T not t *)
+(** Attaches to t *)
+\end{verbatim}
+
+will be converted to:
+
+\begin{verbatim}
+type t = T of string [@ocaml.doc " Attaches to T not t "]
+[@@ocaml.doc " Attaches to t "]
+\end{verbatim}
+
+In the absence of meaningful comment on the last constructor of
+a type, an empty comment~"(**)" can be used instead:
+
+\begin{verbatim}
+type t = T of string
+(**)
+(** Attaches to t *)
+\end{verbatim}
+
+will be converted directly to
+
+\begin{verbatim}
+type t = T of string
+[@@ocaml.doc " Attaches to t "]
+\end{verbatim}
+
+\section{Extended indexing operators \label{s:index-operators} }
+(Introduced in 4.06)
+
+\begin{syntax}
+
+dot-ext:
+ | ('!'||'$'||'%'||'&'||'*'||'+'||'-'||'/'||':'||'='||'>'||'?'||'@'||'^'||'|'||'~') { operator-char }
+;
+expr:
+ ...
+ | expr '.' [module-path '.'] dot-ext ( '(' expr ')' || '[' expr ']' || '{' expr '}' ) [ '<-' expr ]
+;
+operator-name:
+ ...
+ | '.' dot-ext ('()' || '[]' || '{}') ['<-']
+;
+\end{syntax}
+
+
+This extension provides syntactic sugar for getting and setting elements
+for user-defined indexed types. For instance, we can define python-like
+dictionaries with
+\begin{caml_example*}{verbatim}
+module Dict = struct
+include Hashtbl
+let ( .%{} ) tabl index = find tabl index
+let ( .%{}<- ) tabl index value = add tabl index value
+end
+let dict =
+ let dict = Dict.create 10 in
+ let () =
+ dict.Dict.%{"one"} <- 1;
+ let open Dict in
+ dict.%{"two"} <- 2 in
+ dict
+\end{caml_example*}
+\begin{caml_example}{toplevel}
+dict.Dict.%{"one"};;
+let open Dict in dict.%{"two"};;
+\end{caml_example}
+
+\section{Empty variant types\label{s:empty-variants} }
+(Introduced in 4.07.0)
+
+\begin{syntax}
+type-representation:
+ ...
+ | '=' '|'
+\end{syntax}
+This extension allows user to define empty variants.
+Empty variant type can be eliminated by refutation case of pattern matching.
+\begin{caml_example*}{verbatim}
+type t = |
+let f (x: t) = match x with _ -> .
+\end{caml_example*}
--- /dev/null
+\section{Lexical conventions}
+\pdfsection{Lexical conventions}
+%HEVEA\cutname{lex.html}
+\subsubsection*{Blanks}
+
+The following characters are considered as blanks: space,
+horizontal tabulation, carriage return, line feed and form feed. Blanks are
+ignored, but they separate adjacent identifiers, literals and
+keywords that would otherwise be confused as one single identifier,
+literal or keyword.
+
+\subsubsection*{Comments}
+
+Comments are introduced by the two characters @"(*"@, with no
+intervening blanks, and terminated by the characters @"*)"@, with
+no intervening blanks. Comments are treated as blank characters.
+Comments do not occur inside string or character literals. Nested
+comments are handled correctly.
+
+\subsubsection*{Identifiers}
+
+\begin{syntax}
+ident: ( letter || "_" ) { letter || "0" \ldots "9" || "_" || "'" } ;
+capitalized-ident: ("A" \ldots "Z") { letter || "0" \ldots "9" || "_" || "'" } ;
+lowercase-ident:
+ ("a" \ldots "z" || "_") { letter || "0" \ldots "9" || "_" || "'" } ;
+letter: "A" \ldots "Z" || "a" \ldots "z"
+\end{syntax}
+
+Identifiers are sequences of letters, digits, "_" (the underscore
+character), and "'" (the single quote), starting with a
+letter or an underscore.
+Letters contain at least the 52 lowercase and uppercase
+letters from the ASCII set. The current implementation
+also recognizes as letters some characters from the ISO
+8859-1 set (characters 192--214 and 216--222 as uppercase letters;
+characters 223--246 and 248--255 as lowercase letters). This
+feature is deprecated and should be avoided for future compatibility.
+
+All characters in an identifier are
+meaningful. The current implementation accepts identifiers up to
+16000000 characters in length.
+
+In many places, OCaml makes a distinction between capitalized
+identifiers and identifiers that begin with a lowercase letter. The
+underscore character is considered a lowercase letter for this
+purpose.
+
+\subsubsection*{Integer literals}
+
+\begin{syntax}
+integer-literal:
+ ["-"] ("0"\ldots"9") { "0"\ldots"9" || "_" }
+ | ["-"] ("0x"||"0X") ("0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f")
+ { "0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f"||"_" }
+ | ["-"] ("0o"||"0O") ("0"\ldots"7") { "0"\ldots"7"||"_" }
+ | ["-"] ("0b"||"0B") ("0"\ldots"1") { "0"\ldots"1"||"_" }
+\end{syntax}
+
+An integer literal is a sequence of one or more digits, optionally
+preceded by a minus sign. By default, integer literals are in decimal
+(radix 10). The following prefixes select a different radix:
+\begin{tableau}{|l|l|}{Prefix}{Radix}
+\entree{"0x", "0X"}{hexadecimal (radix 16)}
+\entree{"0o", "0O"}{octal (radix 8)}
+\entree{"0b", "0B"}{binary (radix 2)}
+\end{tableau}
+(The initial @"0"@ is the digit zero; the @"O"@ for octal is the letter O.)
+The interpretation of integer literals that fall outside the range of
+representable integer values is undefined.
+
+For convenience and readability, underscore characters (@"_"@) are accepted
+(and ignored) within integer literals.
+
+\subsubsection*{Floating-point literals}
+
+\begin{syntax}
+float-literal:
+ ["-"] ("0"\ldots"9") { "0"\ldots"9"||"_" } ["." { "0"\ldots"9"||"_" }]
+ [("e"||"E") ["+"||"-"] ("0"\ldots"9") { "0"\ldots"9"||"_" }]
+ | ["-"] ("0x"||"0X")
+ ("0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f")
+ { "0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f"||"_" } \\
+ ["." { "0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f"||"_" }]
+ [("p"||"P") ["+"||"-"] ("0"\ldots"9") { "0"\ldots"9"||"_" }]
+\end{syntax}
+
+Floating-point decimal literals consist in an integer part, a
+fractional part and
+an exponent part. The integer part is a sequence of one or more
+digits, optionally preceded by a minus sign. The fractional part is a
+decimal point followed by zero, one or more digits.
+The exponent part is the character @"e"@ or @"E"@ followed by an
+optional @"+"@ or @"-"@ sign, followed by one or more digits. It is
+interpreted as a power of 10.
+The fractional part or the exponent part can be omitted but not both, to
+avoid ambiguity with integer literals.
+The interpretation of floating-point literals that fall outside the
+range of representable floating-point values is undefined.
+
+Floating-point hexadecimal literals are denoted with the @"0x"@ or @"0X"@
+prefix. The syntax is similar to that of floating-point decimal
+literals, with the following differences.
+The integer part and the fractional part use hexadecimal
+digits. The exponent part starts with the character @"p"@ or @"P"@.
+It is written in decimal and interpreted as a power of 2.
+
+For convenience and readability, underscore characters (@"_"@) are accepted
+(and ignored) within floating-point literals.
+
+\subsubsection*{Character literals}
+\label{s:characterliteral}
+
+\begin{syntax}
+char-literal:
+ "'" regular-char "'"
+ | "'" escape-sequence "'"
+;
+escape-sequence:
+ "\" ( "\" || '"' || "'" || "n" || "t" || "b" || "r" || space )
+ | "\" ("0"\ldots"9") ("0"\ldots"9") ("0"\ldots"9")
+ | "\x" ("0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f")
+ ("0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f")
+ | "\o" ("0"\ldots"3") ("0"\ldots"7") ("0"\ldots"7")
+\end{syntax}
+
+Character literals are delimited by @"'"@ (single quote) characters.
+The two single quotes enclose either one character different from
+@"'"@ and @'\'@, or one of the escape sequences below:
+\begin{tableau}{|l|l|}{Sequence}{Character denoted}
+\entree{"\\\\"}{backslash ("\\")}
+\entree{"\\\""}{double quote ("\"")}
+\entree{"\\'"}{single quote ("'")}
+\entree{"\\n"}{linefeed (LF)}
+\entree{"\\r"}{carriage return (CR)}
+\entree{"\\t"}{horizontal tabulation (TAB)}
+\entree{"\\b"}{backspace (BS)}
+\entree{"\\"\var{space}}{space (SPC)}
+\entree{"\\"\var{ddd}}{the character with ASCII code \var{ddd} in decimal}
+\entree{"\\x"\var{hh}}{the character with ASCII code \var{hh} in hexadecimal}
+\entree{"\\o"\var{ooo}}{the character with ASCII code \var{ooo} in octal}
+\end{tableau}
+
+\subsubsection*{String literals}
+\label{s:stringliteral}
+
+\begin{syntax}
+string-literal:
+ '"' { string-character } '"'
+;
+string-character:
+ regular-string-char
+ | escape-sequence
+ | "\u{" {{ "0"\ldots"9"||"A"\ldots"F"||"a"\ldots"f" }} "}"
+ | '\' newline { space || tab }
+\end{syntax}
+
+String literals are delimited by @'"'@ (double quote) characters.
+The two double quotes enclose a sequence of either characters
+different from @'"'@ and @'\'@, or escape sequences from the
+table given above for character literals, or a Unicode character
+escape sequence.
+
+A Unicode character escape sequence is substituted by the UTF-8
+encoding of the specified Unicode scalar value. The Unicode scalar
+value, an integer in the ranges 0x0000...0xD7FF or 0xE000...0x10FFFF,
+is defined using 1 to 6 hexadecimal digits; leading zeros are allowed.
+
+To allow splitting long string literals across lines, the sequence
+"\\"\var{newline}~\var{spaces-or-tabs} (a backslash at the end of a line
+followed by any number of spaces and horizontal tabulations at the
+beginning of the next line) is ignored inside string literals.
+
+The current implementation places practically no restrictions on the
+length of string literals.
+
+\subsubsection*{Naming labels}
+\label{s:labelname}
+
+To avoid ambiguities, naming labels in expressions cannot just be defined
+syntactically as the sequence of the three tokens "~", @ident@ and
+":", and have to be defined at the lexical level.
+
+\begin{syntax}
+label-name: lowercase-ident
+;
+label: "~" label-name ":"
+;
+optlabel: "?" label-name ":"
+\end{syntax}
+
+Naming labels come in two flavours: @label@ for normal arguments and
+@optlabel@ for optional ones. They are simply distinguished by their
+first character, either "~" or "?".
+
+Despite @label@ and @optlabel@ being lexical entities in expressions,
+their expansions @'~' label-name ':'@ and @'?' label-name ':'@ will be
+used in grammars, for the sake of readability. Note also that inside
+type expressions, this expansion can be taken literally, {\em i.e.}
+there are really 3 tokens, with optional blanks between them.
+
+\subsubsection*{Prefix and infix symbols}
+
+%% || '`' lowercase-ident '`'
+
+\begin{syntax}
+infix-symbol:
+ ('=' || '<' || '>' || '@' || '^' || '|' || '&' ||
+ '+' || '-' || '*' || '/' || '$' || '%') { operator-char }
+ | "#" {{ operator-char }}
+;
+prefix-symbol:
+ '!' { operator-char }
+ | ('?' || '~') {{ operator-char }}
+;
+operator-char:
+ '!' || '$' || '%' || '&' || '*' || '+' || '-' || '.' ||
+ '/' || ':' || '<' || '=' || '>' || '?' || '@' ||
+ '^' || '|' || '~'
+\end{syntax}
+See also the following language extensions:
+\hyperref[s:ext-ops]{extension operators} and
+\hyperref[s:index-operators]{extended indexing operators}.
+
+Sequences of ``operator characters'', such as "<=>" or "!!",
+are read as a single token from the @infix-symbol@ or @prefix-symbol@
+class. These symbols are parsed as prefix and infix operators inside
+expressions, but otherwise behave like normal identifiers.
+%% Identifiers starting with a lowercase letter and enclosed
+%% between backquote characters @'`' lowercase-ident '`'@ are also parsed
+%% as infix operators.
+
+\subsubsection*{Keywords}
+
+The identifiers below are reserved as keywords, and cannot be employed
+otherwise:
+\begin{verbatim}
+ and as assert asr begin class
+ constraint do done downto else end
+ exception external false for fun function
+ functor if in include inherit initializer
+ land lazy let lor lsl lsr
+ lxor match method mod module mutable
+ new nonrec object of open or
+ private rec sig struct then to
+ true try type val virtual when
+ while with
+\end{verbatim}
+%
+\goodbreak%
+%
+The following character sequences are also keywords:
+%
+%% FIXME the token >] is not used anywhere in the syntax
+%
+\begin{alltt}
+" != # & && ' ( ) * + , -"
+" -. -> . .. : :: := :> ; ;; <"
+" <- = > >] >} ? [ [< [> [| ]"
+" _ ` { {< | |] || } ~"
+\end{alltt}
+%
+Note that the following identifiers are keywords of the Camlp4
+extensions and should be avoided for compatibility reasons.
+%
+\begin{verbatim}
+ parser value $ $$ $: <: << >> ??
+\end{verbatim}
+
+\subsubsection*{Ambiguities}
+
+Lexical ambiguities are resolved according to the ``longest match''
+rule: when a character sequence can be decomposed into two tokens in
+several different ways, the decomposition retained is the one with the
+longest first token.
+
+\subsubsection*{Line number directives}
+
+\begin{syntax}
+linenum-directive:
+ '#' {{"0" \ldots "9"}}
+ | '#' {{"0" \ldots "9"}} '"' { string-character } '"'
+\end{syntax}
+
+Preprocessors that generate OCaml source code can insert line number
+directives in their output so that error messages produced by the
+compiler contain line numbers and file names referring to the source
+file before preprocessing, instead of after preprocessing.
+A line number directive is composed of a @"#"@ (sharp sign), followed by
+a positive integer (the source line number), optionally followed by a
+character string (the source file name).
+Line number directives are treated as blanks during lexical
+analysis.
+
+% FIXME spaces and tabs are allowed before and after the number
+% FIXME ``string-character'' is inaccurate: everything is allowed except
+% CR, LF, and doublequote; moreover, backslash escapes are not
+% interpreted (especially backslash-doublequote)
+% FIXME any number of random characters are allowed (and ignored) at the
+% end of the line, except CR and LF.
--- /dev/null
+\section{Module types (module specifications)}
+\pdfsection{Module types (module specifications)}
+%HEVEA\cutname{modtypes.html}
+
+Module types are the module-level equivalent of type expressions: they
+specify the general shape and type properties of modules.
+
+\ikwd{sig\@\texttt{sig}}
+\ikwd{end\@\texttt{end}}
+\ikwd{functor\@\texttt{functor}}
+\ikwd{with\@\texttt{with}}
+\ikwd{and\@\texttt{and}}
+\ikwd{val\@\texttt{val}}
+\ikwd{external\@\texttt{external}}
+\ikwd{type\@\texttt{type}}
+\ikwd{exception\@\texttt{exception}}
+\ikwd{class\@\texttt{class}}
+\ikwd{module\@\texttt{module}}
+\ikwd{open\@\texttt{open}}
+\ikwd{include\@\texttt{include}}
+
+\begin{syntax}
+module-type:
+ modtype-path
+ | 'sig' { specification [';;'] } 'end'
+ | 'functor' '(' module-name ':' module-type ')' '->' module-type
+ | module-type '->' module-type
+ | module-type 'with' mod-constraint { 'and' mod-constraint }
+ | '(' module-type ')'
+;
+mod-constraint:
+ 'type' [type-params] typeconstr type-equation { type-constraint }
+ | 'module' module-path '=' extended-module-path
+;
+%BEGIN LATEX
+\end{syntax}
+\begin{syntax}
+%END LATEX
+specification:
+ 'val' value-name ':' typexpr
+ | 'external' value-name ':' typexpr '=' external-declaration
+ | type-definition
+ | 'exception' constr-decl
+ | class-specification
+ | classtype-definition
+ | 'module' module-name ':' module-type
+ | 'module' module-name { '(' module-name ':' module-type ')' }
+ ':' module-type
+ | 'module' 'type' modtype-name
+ | 'module' 'type' modtype-name '=' module-type
+ | 'open' module-path
+ | 'include' module-type
+\end{syntax}
+See also the following language extensions:
+\hyperref[s:module-type-of]{recovering the type of a module},
+\hyperref[s:signature-substitution]{substitution inside a signature},
+\hyperref[s:module-alias]{type-level module aliases},
+\hyperref[s:attributes]{attributes},
+\hyperref[s:extension-nodes]{extension nodes} and
+\hyperref[s:generative-functors]{generative functors}.
+
+\subsection{Simple module types}
+
+The expression @modtype-path@ is equivalent to the module type bound
+to the name @modtype-path@.
+The expression @'(' module-type ')'@ denotes the same type as
+@module-type@.
+
+\subsection{Signatures}
+
+\ikwd{sig\@\texttt{sig}}
+\ikwd{end\@\texttt{end}}
+
+Signatures are type specifications for structures. Signatures
+@'sig' \ldots 'end'@ are collections of type specifications for value
+names, type names, exceptions, module names and module type names. A
+structure will match a signature if the structure provides definitions
+(implementations) for all the names specified in the signature (and
+possibly more), and these definitions meet the type requirements given
+in the signature.
+
+An optional @";;"@ is allowed after each specification in a
+signature. It serves as a syntactic separator with no semantic
+meaning.
+
+\subsubsection*{Value specifications}
+
+\ikwd{val\@\texttt{val}}
+
+A specification of a value component in a signature is written
+@'val' value-name ':' typexpr@, where @value-name@ is the name of the
+value and @typexpr@ its expected type.
+
+\ikwd{external\@\texttt{external}}
+
+The form @'external' value-name ':' typexpr '=' external-declaration@
+is similar, except that it requires in addition the name to be
+implemented as the external function specified in @external-declaration@
+(see chapter~\ref{c:intf-c}).
+
+\subsubsection*{Type specifications}
+
+\ikwd{type\@\texttt{type}}
+
+A specification of one or several type components in a signature is
+written @'type' typedef { 'and' typedef }@ and consists of a sequence
+of mutually recursive definitions of type names.
+
+Each type definition in the signature specifies an optional type
+equation @'=' typexpr@ and an optional type representation
+@'=' constr-decl \ldots@ or @'=' '{' field-decl \ldots '}'@.
+The implementation of the type name in a matching structure must
+be compatible with the type expression specified in the equation (if
+given), and have the specified representation (if given). Conversely,
+users of that signature will be able to rely on the type equation
+or type representation, if given. More precisely, we have the
+following four situations:
+
+\begin{description}
+\item[Abstract type: no equation, no representation.] ~ \\
+Names that are defined as abstract types in a signature can be
+implemented in a matching structure by any kind of type definition
+(provided it has the same number of type parameters). The exact
+implementation of the type will be hidden to the users of the
+structure. In particular, if the type is implemented as a variant type
+or record type, the associated constructors and fields will not be
+accessible to the users; if the type is implemented as an
+abbreviation, the type equality between the type name and the
+right-hand side of the abbreviation will be hidden from the users of the
+structure. Users of the structure consider that type as incompatible
+with any other type: a fresh type has been generated.
+
+\item[Type abbreviation: an equation @'=' typexpr@, no representation.] ~ \\
+The type name must be implemented by a type compatible with @typexpr@.
+All users of the structure know that the type name is
+compatible with @typexpr@.
+
+\item[New variant type or record type: no equation, a representation.] ~ \\
+The type name must be implemented by a variant type or record type
+with exactly the constructors or fields specified. All users of the
+structure have access to the constructors or fields, and can use them
+to create or inspect values of that type. However, users of the
+structure consider that type as incompatible with any other type: a
+fresh type has been generated.
+
+\item[Re-exported variant type or record type: an equation,
+a representation.] ~ \\
+This case combines the previous two: the representation of the type is
+made visible to all users, and no fresh type is generated.
+\end{description}
+
+\subsubsection*{Exception specification}
+
+\ikwd{exception\@\texttt{exception}}
+
+The specification @'exception' constr-decl@ in a signature requires the
+matching structure to provide an exception with the name and arguments
+specified in the definition, and makes the exception available to all
+users of the structure.
+
+\subsubsection*{Class specifications}
+
+\ikwd{class\@\texttt{class}}
+
+A specification of one or several classes in a signature is written
+@'class' class-spec { 'and' class-spec }@ and consists of a sequence
+of mutually recursive definitions of class names.
+
+Class specifications are described more precisely in
+section~\ref{s:class-spec}.
+
+\subsubsection*{Class type specifications}
+
+\ikwd{class\@\texttt{class}}
+\ikwd{type\@\texttt{type}}
+
+A specification of one or several classe types in a signature is
+written @'class' 'type' classtype-def@ @{ 'and' classtype-def }@ and
+consists of a sequence of mutually recursive definitions of class type
+names. Class type specifications are described more precisely in
+section~\ref{s:classtype}.
+
+\subsubsection*{Module specifications}
+
+\ikwd{module\@\texttt{module}}
+
+A specification of a module component in a signature is written
+@'module' module-name ':' module-type@, where @module-name@ is the
+name of the module component and @module-type@ its expected type.
+Modules can be nested arbitrarily; in particular, functors can appear
+as components of structures and functor types as components of
+signatures.
+
+For specifying a module component that is a functor, one may write
+\begin{center}
+@'module' module-name '(' name_1 ':' module-type_1 ')'
+ \ldots '(' name_n ':' module-type_n ')'
+ ':' module-type@
+\end{center}
+instead of
+\begin{center}
+@'module' module-name ':'
+ 'functor' '(' name_1 ':' module-type_1 ')' '->' \ldots
+ '->' module-type@
+\end{center}
+
+\subsubsection*{Module type specifications}
+
+\ikwd{type\@\texttt{type}}
+\ikwd{module\@\texttt{module}}
+
+A module type component of a signature can be specified either as a
+manifest module type or as an abstract module type.
+
+An abstract module type specification
+@'module' 'type' modtype-name@ allows the name @modtype-name@ to be
+implemented by any module type in a matching signature, but hides the
+implementation of the module type to all users of the signature.
+
+A manifest module type specification
+@'module' 'type' modtype-name '=' module-type@
+requires the name @modtype-name@ to be implemented by the module type
+@module-type@ in a matching signature, but makes the equality between
+@modtype-name@ and @module-type@ apparent to all users of the signature.
+
+\subsubsection{Opening a module path}
+
+\ikwd{open\@\texttt{open}}
+
+The expression @'open' module-path@ in a signature does not specify
+any components. It simply affects the parsing of the following items
+of the signature, allowing components of the module denoted by
+@module-path@ to be referred to by their simple names @name@ instead of
+path accesses @module-path '.' name@. The scope of the @"open"@
+stops at the end of the signature expression.
+
+\subsubsection{Including a signature}
+
+\ikwd{include\@\texttt{include}}
+
+The expression @'include' module-type@ in a signature performs textual
+inclusion of the components of the signature denoted by @module-type@.
+It behaves as if the components of the included signature were copied
+at the location of the @'include'@. The @module-type@ argument must
+refer to a module type that is a signature, not a functor type.
+
+\subsection{Functor types}
+
+\ikwd{functor\@\texttt{functor}}
+
+The module type expression
+@'functor' '(' module-name ':' module-type_1 ')' '->' module-type_2@
+is the type of functors (functions from modules to modules) that take
+as argument a module of type @module-type_1@ and return as result a
+module of type @module-type_2@. The module type @module-type_2@ can
+use the name @module-name@ to refer to type components of the actual
+argument of the functor. If the type @module-type_2@ does not
+depend on type components of @module-name@, the module type expression
+can be simplified with the alternative short syntax
+@ module-type_1 '->' module-type_2 @.
+No restrictions are placed on the type of the functor argument; in
+particular, a functor may take another functor as argument
+(``higher-order'' functor).
+
+\subsection{The "with" operator}
+
+\ikwd{with\@\texttt{with}}
+
+Assuming @module-type@ denotes a signature, the expression
+@module-type 'with' mod-constraint@ @{ 'and' mod-constraint }@ denotes
+the same signature where type equations have been added to some of the
+type specifications, as described by the constraints following the
+"with" keyword. The constraint @'type' [type-parameters] typeconstr
+'=' typexpr@ adds the type equation @'=' typexpr@ to the specification
+of the type component named @typeconstr@ of the constrained signature.
+The constraint @'module' module-path '=' extended-module-path@ adds
+type equations to all type components of the sub-structure denoted by
+@module-path@, making them equivalent to the corresponding type
+components of the structure denoted by @extended-module-path@.
+
+For instance, if the module type name "S" is bound to the signature
+\begin{verbatim}
+ sig type t module M: (sig type u end) end
+\end{verbatim}
+then "S with type t=int" denotes the signature
+\begin{verbatim}
+ sig type t=int module M: (sig type u end) end
+\end{verbatim}
+and "S with module M = N" denotes the signature
+\begin{verbatim}
+ sig type t module M: (sig type u=N.u end) end
+\end{verbatim}
+A functor taking two arguments of type "S" that share their "t" component
+is written
+\begin{verbatim}
+ functor (A: S) (B: S with type t = A.t) ...
+\end{verbatim}
+
+Constraints are added left to right. After each constraint has been
+applied, the resulting signature must be a subtype of the signature
+before the constraint was applied. Thus, the @'with'@ operator can
+only add information on the type components of a signature, but never
+remove information.
--- /dev/null
+\section{Module\label{s:module-expr} expressions (module implementations)}
+\pdfsection{Module expressions (module implementations)}
+%HEVEA\cutname{modules.html}
+
+Module expressions are the module-level equivalent of value
+expressions: they evaluate to modules, thus providing implementations
+for the specifications expressed in module types.
+
+\ikwd{struct\@\texttt{struct}}
+\ikwd{end\@\texttt{end}}
+\ikwd{functor\@\texttt{functor}}
+\ikwd{let\@\texttt{let}}
+\ikwd{and\@\texttt{and}}
+\ikwd{external\@\texttt{external}}
+\ikwd{type\@\texttt{type}}
+\ikwd{exception\@\texttt{exception}}
+\ikwd{class\@\texttt{class}}
+\ikwd{module\@\texttt{module}}
+\ikwd{open\@\texttt{open}}
+\ikwd{include\@\texttt{include}}
+
+\begin{syntax}
+module-expr:
+ module-path
+ | 'struct' [ module-items ] 'end'
+ | 'functor' '(' module-name ':' module-type ')' '->' module-expr
+ | module-expr '(' module-expr ')'
+ | '(' module-expr ')'
+ | '(' module-expr ':' module-type ')'
+;
+module-items:
+ {';;'} ( definition || expr ) { {';;'} ( definition || ';;' expr) } {';;'}
+;
+%\end{syntax} \begin{syntax}
+definition:
+ 'let' ['rec'] let-binding { 'and' let-binding }
+ | 'external' value-name ':' typexpr '=' external-declaration
+ | type-definition
+ | exception-definition
+ | class-definition
+ | classtype-definition
+ | 'module' module-name { '(' module-name ':' module-type ')' }
+ [ ':' module-type ] \\ '=' module-expr
+ | 'module' 'type' modtype-name '=' module-type
+ | 'open' module-path
+ | 'include' module-expr
+\end{syntax}
+See also the following language extensions:
+\hyperref[s-recursive-modules]{recursive modules},
+\hyperref[s-first-class-modules]{first-class modules},
+\hyperref[s:explicit-overriding-open]{overriding in open statements},
+\hyperref[s:attributes]{attributes},
+\hyperref[s:extension-nodes]{extension nodes} and
+\hyperref[s:generative-functors]{generative functors}.
+
+\subsection{Simple module expressions}
+
+The expression @module-path@ evaluates to the module bound to the name
+@module-path@.
+
+The expression @'(' module-expr ')'@ evaluates to the same module as
+@module-expr@.
+
+The expression @'(' module-expr ':' module-type ')'@ checks that the
+type of @module-expr@ is a subtype of @module-type@, that is, that all
+components specified in @module-type@ are implemented in
+@module-expr@, and their implementation meets the requirements given
+in @module-type@. In other terms, it checks that the implementation
+@module-expr@ meets the type specification @module-type@. The whole
+expression evaluates to the same module as @module-expr@, except that
+all components not specified in @module-type@ are hidden and can no
+longer be accessed.
+
+\subsection{Structures}
+
+\ikwd{struct\@\texttt{struct}}
+\ikwd{end\@\texttt{end}}
+
+Structures @'struct' \ldots 'end'@ are collections of definitions for
+value names, type names, exceptions, module names and module type
+names. The definitions are evaluated in the order in which they appear
+in the structure. The scopes of the bindings performed by the
+definitions extend to the end of the structure. As a consequence, a
+definition may refer to names bound by earlier definitions in the same
+structure.
+
+For compatibility with toplevel phrases (chapter~\ref{c:camllight}),
+optional @";;"@ are allowed after and before each definition in a structure. These
+@";;"@ have no semantic meanings. Similarly, an @expr@ preceded by ";;" is allowed as
+a component of a structure. It is equivalent to @'let' '_' '=' expr@, i.e. @expr@ is
+evaluated for its side-effects but is not bound to any identifier. If @expr@ is
+the first component of a structure, the preceding ";;" can be omitted.
+
+\subsubsection*{Value definitions}
+
+\ikwd{let\@\texttt{let}}
+
+A value definition @'let' ['rec'] let-binding { 'and' let-binding }@
+bind value names in the same way as a @'let' \ldots 'in' \ldots@ expression
+(see section~\ref{s:localdef}). The value names appearing in the
+left-hand sides of the bindings are bound to the corresponding values
+in the right-hand sides.
+
+\ikwd{external\@\texttt{external}}
+
+A value definition @'external' value-name ':' typexpr '=' external-declaration@
+implements @value-name@ as the external function specified in
+@external-declaration@ (see chapter~\ref{c:intf-c}).
+
+\subsubsection*{Type definitions}
+
+\ikwd{type\@\texttt{type}}
+
+A definition of one or several type components is written
+@'type' typedef { 'and' typedef }@ and consists of a sequence
+of mutually recursive definitions of type names.
+
+\subsubsection*{Exception definitions}
+
+\ikwd{exception\@\texttt{exception}}
+
+Exceptions are defined with the syntax @'exception' constr-decl@
+or @'exception' constr-name '=' constr@.
+
+\subsubsection*{Class definitions}
+
+\ikwd{class\@\texttt{class}}
+
+A definition of one or several classes is written @'class'
+class-binding { 'and' class-binding }@ and consists of a sequence of
+mutually recursive definitions of class names. Class definitions are
+described more precisely in section~\ref{s:classdef}.
+
+\subsubsection*{Class type definitions}
+
+\ikwd{class\@\texttt{class}}
+\ikwd{type\@\texttt{type}}
+
+A definition of one or several classes is written
+@'class' 'type' classtype-def { 'and' classtype-def }@ and consists of
+a sequence of mutually recursive definitions of class type names.
+Class type definitions are described more precisely in
+section~\ref{s:classtype}.
+
+\subsubsection*{Module definitions}
+
+\ikwd{module\@\texttt{module}}
+
+The basic form for defining a module component is
+@'module' module-name '=' module-expr@, which evaluates @module-expr@ and binds
+the result to the name @module-name@.
+
+One can write
+\begin{center}
+@'module' module-name ':' module-type '=' module-expr@
+\end{center}
+instead of
+\begin{center}
+@'module' module-name '=' '(' module-expr ':' module-type ')'@.
+\end{center}
+Another derived form is
+\begin{center}
+@'module' module-name '(' name_1 ':' module-type_1 ')' \ldots
+ '(' name_n ':' module-type_n ')' '=' module-expr@
+\end{center}
+which is equivalent to
+\begin{center}
+@'module' module-name '='
+ 'functor' '(' name_1 ':' module-type_1 ')' '->' \ldots
+ '->' module-expr@
+\end{center}
+
+\subsubsection*{Module type definitions}
+
+\ikwd{type\@\texttt{type}}
+\ikwd{module\@\texttt{module}}
+
+A definition for a module type is written
+@'module' 'type' modtype-name '=' module-type@.
+It binds the name @modtype-name@ to the module type denoted by the
+expression @module-type@.
+
+\subsubsection*{Opening a module path}
+
+\ikwd{open\@\texttt{open}}
+
+The expression @'open' module-path@ in a structure does not define any
+components nor perform any bindings. It simply affects the parsing of
+the following items of the structure, allowing components of the
+module denoted by @module-path@ to be referred to by their simple names
+@name@ instead of path accesses @module-path '.' name@. The scope of
+the @"open"@ stops at the end of the structure expression.
+
+\subsubsection*{Including the components of another structure}
+
+\ikwd{include\@\texttt{include}}
+
+The expression @'include' module-expr@ in a structure re-exports in
+the current structure all definitions of the structure denoted by
+@module-expr@. For instance, if the identifier "S" is bound to the
+module
+\begin{verbatim}
+ struct type t = int let x = 2 end
+\end{verbatim}
+the module expression
+\begin{verbatim}
+ struct include S let y = (x + 1 : t) end
+\end{verbatim}
+is equivalent to the module expression
+\begin{verbatim}
+ struct type t = S.t let x = S.x let y = (x + 1 : t) end
+\end{verbatim}
+The difference between @'open'@ and @'include'@ is that @'open'@
+simply provides short names for the components of the opened
+structure, without defining any components of the current structure,
+while @'include'@ also adds definitions for the components of the
+included structure.
+
+\subsection{Functors}
+
+\subsubsection*{Functor definition}
+
+\ikwd{functor\@\texttt{functor}}
+
+The expression @'functor' '(' module-name ':' module-type ')' '->'
+module-expr@ evaluates to a functor that takes as argument modules of
+the type @module-type_1@, binds @module-name@ to these modules,
+evaluates @module-expr@ in the extended environment, and returns the
+resulting modules as results. No restrictions are placed on the type of the
+functor argument; in particular, a functor may take another functor as
+argument (``higher-order'' functor).
+
+\subsubsection*{Functor application}
+
+The expression @module-expr_1 '(' module-expr_2 ')'@ evaluates
+@module-expr_1@ to a functor and @module-expr_2@ to a module, and
+applies the former to the latter. The type of @module-expr_2@ must
+match the type expected for the arguments of the functor @module-expr_1@.
+
--- /dev/null
+\section{Names} \label{s:names}
+\pdfsection{Names}
+%HEVEA\cutname{names.html}
+
+Identifiers are used to give names to several classes of language
+objects and refer to these objects by name later:
+\begin{itemize}
+\item value names (syntactic class @value-name@),
+\item value constructors and exception constructors (class @constr-name@),
+\item labels (@label-name@, defined in section~\ref{s:labelname}),
+\item polymorphic variant tags (@tag-name@),
+\item type constructors (@typeconstr-name@),
+\item record fields (@field-name@),
+\item class names (@class-name@),
+\item method names (@method-name@),
+\item instance variable names (@inst-var-name@),
+\item module names (@module-name@),
+\item module type names (@modtype-name@).
+\end{itemize}
+These eleven name spaces are distinguished both by the context and by the
+capitalization of the identifier: whether the first letter of the
+identifier is in lowercase (written @lowercase-ident@ below) or in
+uppercase (written @capitalized-ident@). Underscore is considered a
+lowercase letter for this purpose.
+
+\subsubsection*{Naming objects}
+\ikwd{mod\@\texttt{mod}}
+\ikwd{land\@\texttt{land}}
+\ikwd{lor\@\texttt{lor}}
+\ikwd{lxor\@\texttt{lxor}}
+\ikwd{lsl\@\texttt{lsl}}
+\ikwd{lsr\@\texttt{lsr}}
+\ikwd{asr\@\texttt{asr}}
+
+\begin{syntax}
+value-name:
+ lowercase-ident
+ | '(' operator-name ')'
+;
+operator-name:
+ prefix-symbol || infix-op
+;
+infix-op:
+ infix-symbol
+ | '*' || '+' || '-' || '-.' || '=' || '!=' || '<' || '>' || 'or' || '||'
+ || '&' || '&&' || ':='
+ | 'mod' || 'land' || 'lor' || 'lxor' || 'lsl' || 'lsr' || 'asr'
+;
+constr-name:
+ capitalized-ident
+;
+tag-name:
+ capitalized-ident
+;
+typeconstr-name:
+ lowercase-ident
+;
+field-name:
+ lowercase-ident
+;
+module-name:
+ capitalized-ident
+;
+modtype-name:
+ ident
+;
+class-name:
+ lowercase-ident
+;
+inst-var-name:
+ lowercase-ident
+;
+method-name:
+ lowercase-ident
+\end{syntax}
+See also the following language extension:
+\hyperref[s:index-operators]{extended indexing operators}.
+
+As shown above, prefix and infix symbols as well as some keywords can
+be used as value names, provided they are written between parentheses.
+The capitalization rules are summarized in the table below.
+
+\begin{tableau}{|l|l|}{Name space}{Case of first letter}
+\entree{Values}{lowercase}
+\entree{Constructors}{uppercase}
+\entree{Labels}{lowercase}
+\entree{Polymorphic variant tags}{uppercase}
+\entree{Exceptions}{uppercase}
+\entree{Type constructors}{lowercase}
+\entree{Record fields}{lowercase}
+\entree{Classes}{lowercase}
+\entree{Instance variables}{lowercase}
+\entree{Methods}{lowercase}
+\entree{Modules}{uppercase}
+\entree{Module types}{any}
+\end{tableau}
+
+{\it Note on polymorphic variant tags:\/} the current implementation accepts
+lowercase variant tags in addition to capitalized variant tags, but we
+suggest you avoid lowercase variant tags for portability and
+compatibility with future OCaml versions.
+
+\subsubsection*{Referring to named objects}
+
+\begin{syntax}
+value-path:
+ [ module-path '.' ] value-name
+;
+constr:
+ [ module-path '.' ] constr-name
+;
+typeconstr:
+ [ extended-module-path '.' ] typeconstr-name
+;
+field:
+ [ module-path '.' ] field-name
+;
+modtype-path:
+ [ extended-module-path '.' ] modtype-name
+;
+class-path:
+ [ module-path '.' ] class-name
+;
+classtype-path:
+ [ extended-module-path '.' ] class-name
+;
+module-path:
+ module-name { '.' module-name }
+;
+extended-module-path:
+ extended-module-name { '.' extended-module-name }
+;
+extended-module-name:
+ module-name { '(' extended-module-path ')' }
+\end{syntax}
+
+A named object can be referred to either by its name (following the
+usual static scoping rules for names) or by an access path @prefix '.' name@,
+where @prefix@ designates a module and @name@ is the name of an object
+defined in that module. The first component of the path, @prefix@, is
+either a simple module name or an access path @name_1 '.' name_2 \ldots@,
+in case the defining module is itself nested inside other modules.
+For referring to type constructors, module types, or class types,
+the @prefix@ can
+also contain simple functor applications (as in the syntactic class
+@extended-module-path@ above) in case the defining module is the
+result of a functor application.
+
+Label names, tag names, method names and instance variable names need
+not be qualified: the former three are global labels, while the latter
+are local to a class.
--- /dev/null
+\section{Patterns}
+\pdfsection{Patterns}
+\ikwd{as\@\texttt{as}}
+%HEVEA\cutname{patterns.html}
+\begin{syntax}
+pattern:
+ value-name
+ | '_'
+ | constant
+ | pattern 'as' value-name
+ | '(' pattern ')'
+ | '(' pattern ':' typexpr ')'
+ | pattern '|' pattern
+ | constr pattern
+ | "`"tag-name pattern
+ | "#"typeconstr
+ | pattern {{ ',' pattern }}
+ | '{' field [':' typexpr] ['=' pattern]%
+ { ';' field [':' typexpr] ['=' pattern] } [';' '_' ] [ ';' ] '}'
+ | '[' pattern { ';' pattern } [ ';' ] ']'
+ | pattern '::' pattern
+ | '[|' pattern { ';' pattern } [ ';' ] '|]'
+ | char-literal '..' char-literal
+\end{syntax}
+See also the following language extensions: \hyperref[s:lazypat]{lazy patterns},
+\hyperref[s:local-opens]{local opens},
+\hyperref[s-first-class-modules]{first-class modules},
+\hyperref[s:attributes]{attributes},
+\hyperref[s:extension-nodes]{extension nodes} and
+\hyperref[s:exception-match]{exception cases in pattern matching}.
+
+The table below shows the relative precedences and associativity of
+operators and non-closed pattern constructions. The constructions with
+higher precedences come first.
+\ikwd{as\@\texttt{as}}
+\begin{tableau}{|l|l|}{Operator}{Associativity}
+\entree{".."}{--}
+\entree{"lazy" (see section~\ref{s:lazypat})}{--}
+\entree{Constructor application, Tag application}{right}
+\entree{"::"}{right}
+\entree{","}{--}
+\entree{"|"}{left}
+\entree{"as"}{--}
+\end{tableau}
+
+Patterns are templates that allow selecting data structures of a
+given shape, and binding identifiers to components of the data
+structure. This selection operation is called pattern matching; its
+outcome is either ``this value does not match this pattern'', or
+``this value matches this pattern, resulting in the following bindings
+of names to values''.
+
+\subsubsection*{Variable patterns}
+
+A pattern that consists in a value name matches any value,
+binding the name to the value. The pattern @"_"@ also matches
+any value, but does not bind any name.
+
+Patterns are {\em linear\/}: a variable cannot be bound several times by
+a given pattern. In particular, there is no way to test for equality
+between two parts of a data structure using only a pattern (but
+@"when"@ guards can be used for this purpose).
+
+\subsubsection*{Constant patterns}
+
+A pattern consisting in a constant matches the values that
+are equal to this constant.
+
+%% FIXME for negative numbers, blanks are allowed between the minus
+%% sign and the first digit.
+
+\subsubsection*{Alias patterns}
+\ikwd{as\@\texttt{as}}
+
+The pattern @pattern_1 "as" value-name@ matches the same values as
+@pattern_1@. If the matching against @pattern_1@ is successful,
+the name @value-name@ is bound to the matched value, in addition to the
+bindings performed by the matching against @pattern_1@.
+
+\subsubsection*{Parenthesized patterns}
+
+The pattern @"(" pattern_1 ")"@ matches the same values as
+@pattern_1@. A type constraint can appear in a
+parenthesized pattern, as in @"(" pattern_1 ":" typexpr ")"@. This
+constraint forces the type of @pattern_1@ to be compatible with
+@typexpr@.
+
+\subsubsection*{``Or'' patterns}
+
+The pattern @pattern_1 "|" pattern_2@ represents the logical ``or'' of
+the two patterns @pattern_1@ and @pattern_2@. A value matches
+@pattern_1 "|" pattern_2@ if it matches @pattern_1@ or
+@pattern_2@. The two sub-patterns @pattern_1@ and @pattern_2@
+must bind exactly the same identifiers to values having the same types.
+Matching is performed from left to right.
+More precisely,
+in case some value~$v$ matches @pattern_1 "|" pattern_2@, the bindings
+performed are those of @pattern_1@ when $v$ matches @pattern_1@.
+Otherwise, value~$v$ matches @pattern_2@ whose bindings are performed.
+
+
+\subsubsection*{Variant patterns}
+
+The pattern @constr '(' pattern_1 ',' \ldots ',' pattern_n ')'@ matches
+all variants whose
+constructor is equal to @constr@, and whose arguments match
+@pattern_1 \ldots pattern_n@. It is a type error if $n$ is not the
+number of arguments expected by the constructor.
+
+The pattern @constr '_'@ matches all variants whose constructor is
+@constr@.
+
+The pattern @pattern_1 "::" pattern_2@ matches non-empty lists whose
+heads match @pattern_1@, and whose tails match @pattern_2@.
+
+The pattern @"[" pattern_1 ";" \ldots ";" pattern_n "]"@ matches lists
+of length $n$ whose elements match @pattern_1@ \ldots @pattern_n@,
+respectively. This pattern behaves like
+@pattern_1 "::" \ldots "::" pattern_n "::" "[]"@.
+
+\subsubsection*{Polymorphic variant patterns}
+
+The pattern @"`"tag-name pattern_1@ matches all polymorphic variants
+whose tag is equal to @tag-name@, and whose argument matches
+@pattern_1@.
+
+\subsubsection*{Polymorphic variant abbreviation patterns}
+
+If the type @["('a,'b,"\ldots")"] typeconstr = "[" "`"tag-name_1 typexpr_1 "|"
+\ldots "|" "`"tag-name_n typexpr_n"]"@ is defined, then the pattern @"#"typeconstr@
+is a shorthand for the following or-pattern:
+@"(" "`"tag-name_1"(_" ":" typexpr_1")" "|" \ldots "|" "`"tag-name_n"(_"
+":" typexpr_n"))"@. It matches all values of type @"[<" typeconstr "]"@.
+
+\subsubsection*{Tuple patterns}
+
+The pattern @pattern_1 "," \ldots "," pattern_n@ matches $n$-tuples
+whose components match the patterns @pattern_1@ through @pattern_n@. That
+is, the pattern matches the tuple values $(v_1, \ldots, v_n)$ such that
+@pattern_i@ matches $v_i$ for \fromoneto{i}{n}.
+
+\subsubsection*{Record patterns}
+
+The pattern @"{" field_1 ["=" pattern_1] ";" \ldots ";" field_n ["="
+pattern_n] "}"@ matches records that define at least the fields
+@field_1@ through @field_n@, and such that the value associated to
+@field_i@ matches the pattern @pattern_i@, for \fromoneto{i}{n}.
+A single identifier @field_k@ stands for @field_k '=' field_k @,
+and a single qualified identifier @module-path '.' field_k@ stands
+for @module-path '.' field_k '=' field_k @.
+The record value can define more fields than @field_1@ \ldots
+@field_n@; the values associated to these extra fields are not taken
+into account for matching. Optionally, a record pattern can be terminated
+by @';' '_'@ to convey the fact that not all fields of the record type are
+listed in the record pattern and that it is intentional.
+Optional type constraints can be added field by field with
+@"{" field_1 ":" typexpr_1 "=" pattern_1 ";"%
+\ldots ";"field_n ":" typexpr_n "=" pattern_n "}"@ to force the type
+of @field_k@ to be compatible with @typexpr_k@.
+
+
+\subsubsection*{Array patterns}
+
+The pattern @"[|" pattern_1 ";" \ldots ";" pattern_n "|]"@
+matches arrays of length $n$ such that the $i$-th array element
+matches the pattern @pattern_i@, for \fromoneto{i}{n}.
+
+\subsubsection*{Range patterns}
+
+The pattern
+@"'" @c@ "'" ".." "'" @d@ "'"@ is a shorthand for the pattern
+\begin{center}
+@"'" @c@ "'" "|" "'" @c@_1 "'" "|" "'" @c@_2 "'" "|" \ldots
+ "|" "'" @c@_n "'" "|" "'" @d@ "'"@
+\end{center}
+where \nth{c}{1}, \nth{c}{2}, \ldots, \nth{c}{n} are the characters
+that occur between \var{c} and \var{d} in the ASCII character set. For
+instance, the pattern "'0'"@'..'@"'9'" matches all characters that are digits.
--- /dev/null
+\chapter{The OCaml language} \label{c:refman}
+\pdfchapterfold{-12}{Reference manual for the OCaml language}
+%HEVEA\cutname{language.html}
+
+%better html output that way, sniff.
+%HEVEA\subsection*{Foreword}
+%BEGIN LATEX
+\section*{Foreword}
+%END LATEX
+
+This document is intended as a reference manual for the OCaml
+language. It lists the language constructs, and gives their precise
+syntax and informal semantics. It is by no means a tutorial
+introduction to the language: there is not a single example. A good
+working knowledge of OCaml is assumed.
+
+No attempt has been made at mathematical rigor: words are employed
+with their intuitive meaning, without further definition. As a
+consequence, the typing rules have been left out, by lack of the
+mathematical framework required to express them, while they are
+definitely part of a full formal definition of the language.
+
+
+\subsection*{Notations}
+
+The syntax of the language is given in BNF-like notation. Terminal
+symbols are set in typewriter font (@'like' 'this'@).
+Non-terminal symbols are set in italic font (@like that@).
+Square brackets @[\ldots]@ denote optional components. Curly brackets
+@{\ldots}@ denotes zero, one or several repetitions of the enclosed
+components. Curly brackets with a trailing plus sign @{{\ldots}}@
+denote one or several repetitions of the enclosed components.
+Parentheses @(\ldots)@ denote grouping.
+
+%HEVEA\cutdef{section}
+\input{lex}
+\input{values}
+\input{names}
+\input{types}
+\input{const}
+\input{patterns}
+\input{expr}
+\input{typedecl}
+\input{classes}
+\input{modtypes}
+\input{modules}
+\input{compunit}
+%HEVEA\cutend
--- /dev/null
+\section{Type and exception definitions}
+%HEVEA\cutname{typedecl.html}%
+\pdfsection{Type and exception definitions}
+
+\subsection{Type definitions}
+\label{s:type-defs}
+
+Type definitions bind type constructors to data types: either
+variant types, record types, type abbreviations, or abstract data
+types. They also bind the value constructors and record fields
+associated with the definition.
+
+\ikwd{type\@\texttt{type}}
+\ikwd{and\@\texttt{and}}
+\ikwd{nonrec\@\texttt{nonrec}}
+\ikwd{of\@\texttt{of}}
+
+\begin{syntax}
+type-definition:
+ 'type' ['nonrec'] typedef { 'and' typedef }
+;
+typedef:
+ [type-params] typeconstr-name type-information
+;
+type-information:
+ [type-equation] [type-representation] { type-constraint }
+;
+type-equation:
+ '=' typexpr
+;
+type-representation:
+ '=' ['|'] constr-decl { '|' constr-decl }
+ | '=' record-decl
+ | '=' '|'
+;
+type-params:
+ type-param
+ | '(' type-param { "," type-param } ')'
+;
+type-param:
+ [variance] "'" ident
+;
+variance:
+ '+'
+ | '-'
+;
+record-decl:
+ '{' field-decl { ';' field-decl } [';'] '}'
+;
+constr-decl:
+ (constr-name || '[]' || '(::)') [ 'of' constr-args ]
+;
+constr-args:
+ typexpr { '*' typexpr }
+;
+field-decl:
+ ['mutable'] field-name ':' poly-typexpr
+;
+type-constraint:
+ 'constraint' "'" ident '=' typexpr
+\end{syntax}
+\ikwd{mutable\@\texttt{mutable}}
+\ikwd{constraint\@\texttt{constraint}}
+See also the following language extensions:
+\hyperref[s:private-types]{private types},
+\hyperref[s:gadts]{generalized algebraic datatypes},
+\hyperref[s:attributes]{attributes},
+\hyperref[s:extension-nodes]{extension nodes},
+\hyperref[s:extensible-variants]{extensible variant types} and
+\hyperref[s:inline-records]{inline records}.
+
+Type definitions are introduced by the "type" keyword, and
+consist in one or several simple definitions, possibly mutually
+recursive, separated by the "and" keyword. Each simple definition
+defines one type constructor.
+
+A simple definition consists in a lowercase identifier, possibly
+preceded by one or several type parameters, and followed by an
+optional type equation, then an optional type representation, and then
+a constraint clause. The identifier is the name of the type
+constructor being defined.
+
+In the right-hand side of type definitions, references to one of the
+type constructor name being defined are considered as recursive,
+unless "type" is followed by "nonrec". The "nonrec" keyword was
+introduced in OCaml 4.02.2.
+
+The optional type parameters are either one type variable @"'" ident@,
+for type constructors with one parameter, or a list of type variables
+@"('"ident_1,\ldots,"'"ident_n")"@, for type constructors with several
+parameters. Each type parameter may be prefixed by a variance
+constraint @"+"@ (resp. @"-"@) indicating that the parameter is
+covariant (resp. contravariant). These type parameters can appear in
+the type expressions of the right-hand side of the definition,
+optionally restricted by a variance constraint ; {\em i.e.\/} a
+covariant parameter may only appear on the right side of a functional
+arrow (more precisely, follow the left branch of an even number of
+arrows), and a contravariant parameter only the left side (left branch of
+an odd number of arrows). If the type has a representation or
+an equation, and the parameter is free ({\em i.e.\/} not bound via a
+type constraint to a constructed type), its variance constraint is
+checked but subtyping {\em etc.\/} will use the inferred variance of the
+parameter, which may be less restrictive; otherwise ({\em i.e.\/} for abstract
+types or non-free parameters), the variance must be given explicitly,
+and the parameter is invariant if no variance is given.
+
+The optional type equation @'=' typexpr@ makes the defined type
+equivalent to the type expression @typexpr@:
+one can be substituted for the other during typing.
+If no type equation is given, a new type is generated: the defined type
+is incompatible with any other type.
+
+The optional type representation describes the data structure
+representing the defined type, by giving the list of associated
+constructors (if it is a variant type) or associated fields (if it is
+a record type). If no type representation is given, nothing is
+assumed on the structure of the type besides what is stated in the
+optional type equation.
+
+The type representation @'=' ['|'] constr-decl { '|' constr-decl }@
+describes a variant type. The constructor declarations
+@constr-decl_1, \ldots, constr-decl_n@ describe the constructors
+associated to this variant type. The constructor
+declaration @constr-name 'of' typexpr_1 '*' \ldots '*' typexpr_n@
+declares the name @constr-name@ as a non-constant constructor, whose
+arguments have types @typexpr_1@ \ldots @typexpr_n@.
+The constructor declaration @constr-name@
+declares the name @constr-name@ as a constant
+constructor. Constructor names must be capitalized.
+
+The type representation @'=' '{' field-decl { ';' field-decl } [';'] '}'@
+describes a record type. The field declarations @field-decl_1, \ldots,
+field-decl_n@ describe the fields associated to this record type.
+The field declaration @field-name ':' poly-typexpr@ declares
+@field-name@ as a field whose argument has type @poly-typexpr@.
+The field declaration @'mutable' field-name ':' poly-typexpr@
+\ikwd{mutable\@\texttt{mutable}}
+behaves similarly; in addition, it allows physical modification of
+this field.
+Immutable fields are covariant, mutable fields are non-variant.
+Both mutable and immutable fields may have explicitly polymorphic
+types. The polymorphism of the contents is statically checked whenever
+a record value is created or modified. Extracted values may have their
+types instantiated.
+
+The two components of a type definition, the optional equation and the
+optional representation, can be combined independently, giving
+rise to four typical situations:
+
+\begin{description}
+\item[Abstract type: no equation, no representation.] ~\\
+When appearing in a module signature, this definition specifies
+nothing on the type constructor, besides its number of parameters:
+its representation is hidden and it is assumed incompatible with any
+other type.
+
+\item[Type abbreviation: an equation, no representation.] ~\\
+This defines the type constructor as an abbreviation for the type
+expression on the right of the @'='@ sign.
+
+\item[New variant type or record type: no equation, a representation.] ~\\
+This generates a new type constructor and defines associated
+constructors or fields, through which values of that type can be
+directly built or inspected.
+
+\item[Re-exported variant type or record type: an equation,
+a representation.] ~\\
+In this case, the type constructor is defined as an abbreviation for
+the type expression given in the equation, but in addition the
+constructors or fields given in the representation remain attached to
+the defined type constructor. The type expression in the equation part
+must agree with the representation: it must be of the same kind
+(record or variant) and have exactly the same constructors or fields,
+in the same order, with the same arguments.
+\end{description}
+
+The type variables appearing as type parameters can optionally be
+prefixed by "+" or "-" to indicate that the type constructor is
+covariant or contravariant with respect to this parameter. This
+variance information is used to decide subtyping relations when
+checking the validity of @":>"@ coercions (see section \ref{s:coercions}).
+
+For instance, "type +'a t" declares "t" as an abstract type that is
+covariant in its parameter; this means that if the type $\tau$ is a
+subtype of the type $\sigma$, then $\tau " t"$ is a subtype of $\sigma
+" t"$. Similarly, "type -'a t" declares that the abstract type "t" is
+contravariant in its parameter: if $\tau$ is a subtype of $\sigma$, then
+$\sigma " t"$ is a subtype of $\tau " t"$. If no "+" or "-" variance
+annotation is given, the type constructor is assumed non-variant in the
+corresponding parameter. For instance, the abstract type declaration
+"type 'a t" means that $\tau " t"$ is neither a subtype nor a
+supertype of $\sigma " t"$ if $\tau$ is subtype of $\sigma$.
+
+The variance indicated by the "+" and "-" annotations on parameters
+is enforced only for abstract and private types, or when there are
+type constraints.
+Otherwise, for abbreviations, variant and record types without type
+constraints, the variance properties of the type constructor
+are inferred from its definition, and the variance annotations are
+only checked for conformance with the definition.
+
+\ikwd{constraint\@\texttt{constraint}}
+The construct @ 'constraint' "'" ident '=' typexpr @ allows the
+specification of
+type parameters. Any actual type argument corresponding to the type
+parameter @ident@ has to be an instance of @typexpr@ (more precisely,
+@ident@ and @typexpr@ are unified). Type variables of @typexpr@ can
+appear in the type equation and the type declaration.
+
+\subsection{Exception definitions} \label{s:excdef}
+\ikwd{exception\@\texttt{exception}}
+
+\begin{syntax}
+exception-definition:
+ 'exception' constr-decl
+ | 'exception' constr-name '=' constr
+\end{syntax}
+
+Exception definitions add new constructors to the built-in variant
+type \verb"exn" of exception values. The constructors are declared as
+for a definition of a variant type.
+
+The form @'exception' constr-decl@
+generates a new exception, distinct from all other exceptions in the system.
+The form @'exception' constr-name '=' constr@
+gives an alternate name to an existing exception.
--- /dev/null
+\section{Type expressions}
+\pdfsection{Type expressions}
+%HEVEA\cutname{types.html}
+\ikwd{as\@\texttt{as}}
+
+\begin{syntax}
+typexpr:
+ "'" ident
+ | "_"
+ | '(' typexpr ')'
+ | [['?']label-name':'] typexpr '->' typexpr
+ | typexpr {{ '*' typexpr }}
+ | typeconstr
+ | typexpr typeconstr
+ | '(' typexpr { ',' typexpr } ')' typeconstr
+ | typexpr 'as' "'" ident
+ | polymorphic-variant-type
+ | '<' ['..'] '>'
+ | '<' method-type { ';' method-type } [';' || ';' '..'] '>'
+ | '#' class-path
+ | typexpr '#' class-path
+ | '(' typexpr { ',' typexpr } ')' '#' class-path
+;
+poly-typexpr:
+ typexpr
+ | {{ "'" ident }} '.' typexpr
+;
+method-type:
+ method-name ':' poly-typexpr
+\end{syntax}
+See also the following language extensions:
+\hyperref[s-first-class-modules]{first-class modules},
+\hyperref[s:attributes]{attributes} and
+\hyperref[s:extension-nodes]{extension nodes}.
+
+The table below shows the relative precedences and associativity of
+operators and non-closed type constructions. The constructions with
+higher precedences come first.
+\ikwd{as\@\texttt{as}}
+\begin{tableau}{|l|l|}{Operator}{Associativity}
+\entree{Type constructor application}{--}
+\entree{"#"}{--}
+\entree{"*"}{--}
+\entree{"->"}{right}
+\entree{"as"}{--}
+\end{tableau}
+
+Type expressions denote types in definitions of data types as well as
+in type constraints over patterns and expressions.
+
+\subsubsection*{Type variables}
+
+The type expression @"'" ident@ stands for the type variable named
+@ident@. The type expression @"_"@ stands for either an anonymous type
+variable or anonymous type parameters. In data type definitions, type
+variables are names for the data type parameters. In type constraints,
+they represent unspecified types that can be instantiated by any type
+to satisfy the type constraint. In general the scope of a named type
+variable is the whole top-level phrase where it appears, and it can
+only be generalized when leaving this scope. Anonymous variables have
+no such restriction. In the following cases, the scope of named type
+variables is restricted to the type expression where they appear:
+1) for universal (explicitly polymorphic) type variables;
+2) for type variables that only appear in public method specifications
+(as those variables will be made universal, as described in
+section~\ref{sec-methspec});
+3) for variables used as aliases, when the type they are aliased to
+would be invalid in the scope of the enclosing definition ({\it i.e.}
+when it contains free universal type variables, or locally
+defined types.)
+
+\subsubsection*{Parenthesized types}
+
+The type expression @"(" typexpr ")"@ denotes the same type as
+@typexpr@.
+
+\subsubsection*{Function types}
+
+The type expression @typexpr_1 '->' typexpr_2@ denotes the type of
+functions mapping arguments of type @typexpr_1@ to results of type
+@typexpr_2@.
+
+@label-name ':' typexpr_1 '->' typexpr_2@ denotes the same function type, but
+the argument is labeled @label@.
+
+@'?' label-name ':' typexpr_1 '->' typexpr_2@ denotes the type of functions
+mapping an optional labeled argument of type @typexpr_1@ to results of
+type @typexpr_2@. That is, the physical type of the function will be
+@typexpr_1 "option" '->' typexpr_2@.
+
+\subsubsection*{Tuple types}
+
+The type expression @typexpr_1 '*' \ldots '*' typexpr_n@
+denotes the type of tuples whose elements belong to types @typexpr_1,
+\ldots typexpr_n@ respectively.
+
+\subsubsection*{Constructed types}
+
+Type constructors with no parameter, as in @typeconstr@, are type
+expressions.
+
+The type expression @typexpr typeconstr@, where @typeconstr@ is a type
+constructor with one parameter, denotes the application of the unary type
+constructor @typeconstr@ to the type @typexpr@.
+
+The type expression @(typexpr_1,\ldots,typexpr_n) typeconstr@, where
+@typeconstr@ is a type constructor with $n$ parameters, denotes the
+application of the $n$-ary type constructor @typeconstr@ to the types
+@typexpr_1@ through @typexpr_n@.
+
+In the type expression @ "_" typeconstr @, the anonymous type expression
+@ "_" @ stands in for anonymous type parameters and is equivalent to
+@ ("_", \ldots,"_") @ with as many repetitions of "_" as the arity of
+@typeconstr@.
+
+\subsubsection*{Aliased and recursive types}
+
+\ikwd{as\@\texttt{as}}
+
+The type expression @typexpr 'as' "'" ident@ denotes the same type as
+@typexpr@, and also binds the type variable @ident@ to type @typexpr@ both
+in @typexpr@ and in other types. In general the scope of an alias is
+the same as for a named type variable, and covers the whole enclosing
+definition. If the type variable
+@ident@ actually occurs in @typexpr@, a recursive type is created. Recursive
+types for which there exists a recursive path that does not contain
+an object or polymorphic variant type constructor are rejected, except
+when the "-rectypes" mode is selected.
+
+If @"'" ident@ denotes an explicit polymorphic variable, and @typexpr@
+denotes either an object or polymorphic variant type, the row variable
+of @typexpr@ is captured by @"'" ident@, and quantified upon.
+
+\subsubsection*{Polymorphic variant types}
+\ikwd{of\@\texttt{of}}
+
+\begin{syntax}
+polymorphic-variant-type:
+ '[' tag-spec-first { '|' tag-spec } ']'
+ | '[>' [ tag-spec ] { '|' tag-spec } ']'
+ | '[<' ['|'] tag-spec-full { '|' tag-spec-full }
+ [ '>' {{ '`'tag-name }} ] ']'
+;
+%\end{syntax} \begin{syntax}
+tag-spec-first:
+ '`'tag-name [ 'of' typexpr ]
+ | [ typexpr ] '|' tag-spec
+;
+tag-spec:
+ '`'tag-name [ 'of' typexpr ]
+ | typexpr
+;
+tag-spec-full:
+ '`'tag-name [ 'of' ['&'] typexpr { '&' typexpr } ]
+ | typexpr
+\end{syntax}
+
+Polymorphic variant types describe the values a polymorphic variant
+may take.
+
+The first case is an exact variant type: all possible tags are
+known, with their associated types, and they can all be present.
+Its structure is fully known.
+
+The second case is an open variant type, describing a polymorphic
+variant value: it gives the list of all tags the value could take,
+with their associated types. This type is still compatible with a
+variant type containing more tags. A special case is the unknown
+type, which does not define any tag, and is compatible with any
+variant type.
+
+The third case is a closed variant type. It gives information about
+all the possible tags and their associated types, and which tags are
+known to potentially appear in values. The exact variant type (first
+case) is
+just an abbreviation for a closed variant type where all possible tags
+are also potentially present.
+
+In all three cases, tags may be either specified directly in the
+@'`'tag-name ["of" typexpr]@ form, or indirectly through a type
+expression, which must expand to an
+exact variant type, whose tag specifications are inserted in its
+place.
+
+Full specifications of variant tags are only used for non-exact closed
+types. They can be understood as a conjunctive type for the argument:
+it is intended to have all the types enumerated in the
+specification.
+
+Such conjunctive constraints may be unsatisfiable. In such a case the
+corresponding tag may not be used in a value of this type. This
+does not mean that the whole type is not valid: one can still use
+other available tags.
+Conjunctive constraints are mainly intended as output from the type
+checker. When they are used in source programs, unsolvable constraints
+may cause early failures.
+
+\subsubsection*{Object types}
+
+An object type
+@'<' [method-type { ';' method-type }] '>'@
+is a record of method types.
+
+Each method may have an explicit polymorphic type: @{{ "'" ident }}
+'.' typexpr@. Explicit polymorphic variables have a local scope, and
+an explicit polymorphic type can only be unified to an
+equivalent one, where only the order and names of polymorphic
+variables may change.
+
+The type @'<' {method-type ';'} '..' '>'@ is the
+type of an object whose method names and types are described by
+@method-type_1, \ldots, method-type_n@, and possibly some other
+methods represented by the ellipsis. This ellipsis actually is
+a special kind of type variable (called {\em row variable} in the
+literature) that stands for any number of extra method types.
+
+\subsubsection*{\#-types}
+\label{s:sharp-types}
+
+The type @'#' class-path@ is a special kind of abbreviation. This
+abbreviation unifies with the type of any object belonging to a subclass
+of class @class-path@.
+%
+It is handled in a special way as it usually hides a type variable (an
+ellipsis, representing the methods that may be added in a subclass).
+In particular, it vanishes when the ellipsis gets instantiated.
+%
+Each type expression @'#' class-path@ defines a new type variable, so
+type @'#' class-path '->' '#' class-path@ is usually not the same as
+type @('#' class-path 'as' "'" ident) '->' "'" ident@.
+%
+
+Use of \#-types to abbreviate polymorphic variant types is deprecated.
+If @@t@@ is an exact variant type then @"#"@t@@ translates to @"[<" @t@"]"@,
+and @"#"@t@"[>" "`"tag_1 \dots"`"tag_k"]"@ translates to
+@"[<" @t@ ">" "`"tag_1 \dots"`"tag_k"]"@
+
+\subsubsection*{Variant and record types}
+
+There are no type expressions describing (defined) variant types nor
+record types, since those are always named, i.e. defined before use
+and referred to by name. Type definitions are described in
+section~\ref{s:type-defs}.
--- /dev/null
+\section{Values}
+\pdfsection{Values}
+%HEVEA\cutname{values.html}
+
+This section describes the kinds of values that are manipulated by
+OCaml programs.
+
+\subsection{Base values}
+
+\subsubsection*{Integer numbers}
+
+Integer values are integer numbers from $-2^{30}$ to $2^{30}-1$, that
+is $-1073741824$ to $1073741823$. The implementation may support a
+wider range of integer values: on 64-bit platforms, the current
+implementation supports integers ranging from $-2^{62}$ to $2^{62}-1$.
+
+\subsubsection*{Floating-point numbers}
+
+Floating-point values are numbers in floating-point representation.
+The current implementation uses double-precision floating-point
+numbers conforming to the IEEE 754 standard, with 53 bits of mantissa
+and an exponent ranging from $-1022$ to $1023$.
+
+\subsubsection*{Characters}
+
+Character values are represented as 8-bit integers between 0 and 255.
+Character codes between 0 and 127 are interpreted following the ASCII
+standard. The current implementation interprets character codes
+between 128 and 255 following the ISO 8859-1 standard.
+
+\subsubsection*{Character strings} \label{s:string-val}
+
+String values are finite sequences of characters. The current
+implementation supports strings containing up to $2^{24} - 5$
+characters (16777211 characters); on 64-bit platforms, the limit is
+$2^{57} - 9$.
+
+\subsection{Tuples}
+
+Tuples of values are written @'('@v@_1',' \ldots',' @v@_n')'@, standing for the
+$n$-tuple of values @@v@_1@ to @@v@_n@. The current implementation
+supports tuple of up to $2^{22} - 1$ elements (4194303 elements).
+
+\subsection{Records}
+
+Record values are labeled tuples of values. The record value written
+@'{' field_1 '=' @v@_1';' \ldots';' field_n '=' @v@_n '}'@ associates the value
+@@v@_i@ to the record field @field_i@, for $i = 1 \ldots n$. The current
+implementation supports records with up to $2^{22} - 1$ fields
+(4194303 fields).
+
+\subsection{Arrays}
+
+Arrays are finite, variable-sized sequences of values of the same
+type. The current implementation supports arrays containing up to
+$2^{22} - 1$ elements (4194303 elements) unless the elements are
+floating-point numbers (2097151 elements in this case); on 64-bit
+platforms, the limit is $2^{54} - 1$ for all arrays.
+
+\subsection{Variant values}
+
+Variant values are either a constant constructor, or a non-constant
+constructor applied to a number of values. The former case is written
+@constr@; the latter case is written @constr '('@v@_1',' ... ',' @v@_n
+')'@, where the @@v@_i@ are said to be the arguments of the non-constant
+constructor @constr@. The parentheses may be omitted if there is only
+one argument.
+
+The following constants are treated like built-in constant
+constructors:
+\begin{tableau}{|l|l|}{Constant}{Constructor}
+\entree{"false"}{the boolean false}
+\entree{"true"}{the boolean true}
+\entree{"()"}{the ``unit'' value}
+\entree{"[]"}{the empty list}
+\end{tableau}
+
+The current implementation limits each variant type to have at most
+246 non-constant constructors and $2^{30}-1$ constant constructors.
+
+\subsection{Polymorphic variants}
+
+Polymorphic variants are an alternate form of variant values, not
+belonging explicitly to a predefined variant type, and following
+specific typing rules. They can be either constant, written
+@"`"tag-name@, or non-constant, written @"`"tag-name'('@v@')'@.
+
+\subsection{Functions}
+
+Functional values are mappings from values to values.
+
+\subsection{Objects}
+
+Objects are composed of a hidden internal state which is a
+record of instance variables, and a set of methods for accessing and
+modifying these variables. The structure of an object is described by
+the toplevel class that created it.
--- /dev/null
+/* fira-sans-regular - latin */
+@font-face {
+ font-family: 'Fira Sans';
+ font-style: normal;
+ font-weight: 400;
+ src: url('/pub/docs/manual-ocaml/fonts/fira-sans-v8-latin-regular.eot'); /* IE9 Compat Modes */
+ src: local('Fira Sans Regular'), local('FiraSans-Regular'),
+ url('/pub/docs/manual-ocaml/fonts/fira-sans-v8-latin-regular.eot?#iefix') format('embedded-opentype'), /* IE6-IE8 */
+ url('/pub/docs/manual-ocaml/fonts/fira-sans-v8-latin-regular.woff2') format('woff2'), /* Super Modern Browsers */
+ url('/pub/docs/manual-ocaml/fonts/fira-sans-v8-latin-regular.woff') format('woff'), /* Modern Browsers */
+ url('/pub/docs/manual-ocaml/fonts/fira-sans-v8-latin-regular.ttf') format('truetype'), /* Safari, Android, iOS */
+ url('/pub/docs/manual-ocaml/fonts/fira-sans-v8-latin-regular.svg#FiraSans') format('svg'); /* Legacy iOS */
+}
+
+
+a:visited {color : #416DFF; text-decoration : none; }
+a:link {color : #416DFF; text-decoration : none; }
+a:hover {color : Black; text-decoration : underline; }
+a:active {color : Black; text-decoration : underline; }
+.keyword { font-weight : bold ; color : Red }
+.keywordsign { color : #C04600 }
+.comment { color : Green }
+.constructor { color : Blue }
+.type { color : #5C6585 }
+.string { color : Maroon }
+.warning { color : Red ; font-weight : bold }
+.info { margin-left : 3em; margin-right : 3em }
+.code { color : #465F91 ; }
+h1 { font-size : 2rem ; text-align: center; }
+
+h2, h3, h4, h5, h6, div.h7, div.h8, div.h9 {
+ font-size: 1.75rem;
+ border: 1px solid #000;
+ margin-top: 20px;
+ margin-bottom: 2px;
+ text-align: center;
+ padding: 8px;
+ font-family: "Fira Sans", sans-serif;
+ font-weight: normal;
+}
+h1 {
+ font-family: "Fira Sans", sans-serif;
+ padding: 10px;
+}
+
+h2 { background-color: #90BDFF; }
+h3 { background-color: #90DDFF; }
+h4 { background-color: #90EDFF; }
+h5 { background-color: #90FDFF; }
+h6 { background-color: #90BDFF; }
+div.h7 { background-color: #90DDFF; }
+div.h8 { background-color: #F0FFFF; }
+div.h9 { background-color: #FFFFFF; }
+
+.typetable { border-style : hidden }
+.indextable { border-style : hidden }
+.paramstable { border-style : hidden ; padding: 5pt 5pt}
+body {
+ background-color : #f7f7f7;
+ font-size: 1rem;
+ max-width: 800px;
+ width: 85%;
+ margin: auto;
+ padding-bottom: 30px;
+}
+td {
+ font-size: 1rem;
+}
+.navbar { /* previous - up - next */
+ position: absolute;
+ left: 10px;
+ top: 10px;
+}
+tr { background-color : #f7f7f7 }
+td.typefieldcomment { background-color : #f7f7f7 }
+pre { margin-bottom: 4px; white-space: pre-wrap; }
+div.sig_block {margin-left: 2em}
+ul.info-attributes { list-style: none; margin: 0; padding: 0; }
+div.info > p:first-child{ margin-top:0; }
+div.info-desc > p:first-child { margin-top:0; margin-bottom:0; }
--- /dev/null
+*.aux
+*.dvi
+*.idx
+*.ilg
+*.ind
+*.log
+*.toc
+*.ipr
+*.txt
+*.pdf
+*.ps
+pdfmanual.out
+manual.out
--- /dev/null
+*.aux
+*.dvi
+*.idx
+*.ilg
+*.ind
+*.log
+*.toc
+*.ipr
+*.txt
+*.pdf
+*.ps
+pdfmanual.out
+manual.out
--- /dev/null
+manual.txt
+manual.hmanual.kwd
+*.haux
+*.hind
+*.htoc
--- /dev/null
+manual.txt
+manual.hmanual.kwd
+*.haux
+*.hind
+*.htoc
--- /dev/null
+*.tex
+*.htex
--- /dev/null
+*.tex
+*.htex
--- /dev/null
+FILES= coreexamples.tex lablexamples.tex objectexamples.tex moduleexamples.tex\
+advexamples.tex polymorphism.tex
+
+TOPDIR=../../..
+include $(TOPDIR)/Makefile.tools
+
+LD_PATH="$(TOPDIR)/otherlibs/str:$(TOPDIR)/otherlibs/unix"
+
+CAMLLATEX=$(SET_LD_PATH) $(OCAMLRUN) ../../tools/caml-tex2
+TEXQUOTE=../../tools/texquote2
+
+ALLFILES=$(FILES)
+
+etex-files: $(ALLFILES)
+all: $(ALLFILES)
+
+clean:
+ rm -f $(ALLFILES)
+
+.SUFFIXES:
+.SUFFIXES: .etex .tex
+
+.etex.tex:
+ @$(CAMLLATEX) -caml "TERM=norepeat $(OCAML)" -n 80 -v false\
+ -o $*.caml_tex_error.tex $*.etex\
+ && mv $*.caml_tex_error.tex $*.gen.tex\
+ && $(TEXQUOTE) < $*.gen.tex > $*.texquote_error.tex\
+ && mv $*.texquote_error.tex $*.tex\
+ || printf "Failure when generating %s\n" $*.tex
+
+$(ALLFILES): ../../tools/caml-tex2 $(TEXQUOTE)
--- /dev/null
+\chapter{Advanced examples with classes and modules}
+\pdfchapterfold{-3}{Tutorial: Advanced examples with classes and modules}
+%HEVEA\cutname{advexamples.html}
+\label{c:advexamples}
+
+{\it (Chapter written by Didier Rémy)}
+
+\bigskip
+
+\noindent
+
+In this chapter, we show some larger examples using objects, classes
+and modules. We review many of the object features simultaneously on
+the example of a bank account. We show how modules taken from the
+standard library can be expressed as classes. Lastly, we describe a
+programming pattern known as {\em virtual types} through the example
+of window managers.
+
+\section{Extended example: bank accounts}
+\pdfsection{Extended example: bank accounts}
+\label{ss:bank-accounts}
+
+In this section, we illustrate most aspects of Object and inheritance
+by refining, debugging, and specializing the following
+initial naive definition of a simple bank account. (We reuse the
+module "Euro" defined at the end of chapter~\ref{c:objectexamples}.)
+\begin{caml_eval}
+module type MONEY =
+ sig
+ type t
+ class c : float ->
+ object ('a)
+ val repr : t
+ method value : t
+ method print : unit
+ method times : float -> 'a
+ method leq : 'a -> bool
+ method plus : 'a -> 'a
+ end
+ end;;
+module Euro : MONEY =
+ struct
+ type t = float
+ class c x =
+ object (self : 'a)
+ val repr = x
+ method value = repr
+ method print = print_float repr
+ method times k = {< repr = k *. x >}
+ method leq (p : 'a) = repr <= p#value
+ method plus (p : 'a) = {< repr = x +. p#value >}
+ end
+ end;;
+\end{caml_eval}
+\begin{caml_example}{toplevel}
+let euro = new Euro.c;;
+let zero = euro 0.;;
+let neg x = x#times (-1.);;
+class account =
+ object
+ val mutable balance = zero
+ method balance = balance
+ method deposit x = balance <- balance # plus x
+ method withdraw x =
+ if x#leq balance then (balance <- balance # plus (neg x); x) else zero
+ end;;
+let c = new account in c # deposit (euro 100.); c # withdraw (euro 50.);;
+\end{caml_example}
+We now refine this definition with a method to compute interest.
+\begin{caml_example}{toplevel}
+class account_with_interests =
+ object (self)
+ inherit account
+ method private interest = self # deposit (self # balance # times 0.03)
+ end;;
+\end{caml_example}
+We make the method "interest" private, since clearly it should not be
+called freely from the outside. Here, it is only made accessible to subclasses
+that will manage monthly or yearly updates of the account.
+
+We should soon fix a bug in the current definition: the deposit method can
+be used for withdrawing money by depositing negative amounts. We can
+fix this directly:
+\begin{caml_example}{toplevel}
+class safe_account =
+ object
+ inherit account
+ method deposit x = if zero#leq x then balance <- balance#plus x
+ end;;
+\end{caml_example}
+However, the bug might be fixed more safely by the following definition:
+\begin{caml_example}{toplevel}
+class safe_account =
+ object
+ inherit account as unsafe
+ method deposit x =
+ if zero#leq x then unsafe # deposit x
+ else raise (Invalid_argument "deposit")
+ end;;
+\end{caml_example}
+In particular, this does not require the knowledge of the implementation of
+the method "deposit".
+
+To keep track of operations, we extend the class with a mutable field
+"history" and a private method "trace" to add an operation in the
+log. Then each method to be traced is redefined.
+\begin{caml_example}{toplevel}
+type 'a operation = Deposit of 'a | Retrieval of 'a;;
+class account_with_history =
+ object (self)
+ inherit safe_account as super
+ val mutable history = []
+ method private trace x = history <- x :: history
+ method deposit x = self#trace (Deposit x); super#deposit x
+ method withdraw x = self#trace (Retrieval x); super#withdraw x
+ method history = List.rev history
+ end;;
+\end{caml_example}
+%% \label{ss:bank:initializer}
+One may wish to open an account and simultaneously deposit some initial
+amount. Although the initial implementation did not address this
+requirement, it can be achieved by using an initializer.
+\begin{caml_example}{toplevel}
+class account_with_deposit x =
+ object
+ inherit account_with_history
+ initializer balance <- x
+ end;;
+\end{caml_example}
+A better alternative is:
+\begin{caml_example}{toplevel}
+class account_with_deposit x =
+ object (self)
+ inherit account_with_history
+ initializer self#deposit x
+ end;;
+\end{caml_example}
+Indeed, the latter is safer since the call to "deposit" will automatically
+benefit from safety checks and from the trace.
+Let's test it:
+\begin{caml_example}{toplevel}
+let ccp = new account_with_deposit (euro 100.) in
+let _balance = ccp#withdraw (euro 50.) in
+ccp#history;;
+\end{caml_example}
+Closing an account can be done with the following polymorphic function:
+\begin{caml_example}{toplevel}
+let close c = c#withdraw c#balance;;
+\end{caml_example}
+Of course, this applies to all sorts of accounts.
+
+Finally, we gather several versions of the account into a module "Account"
+abstracted over some currency.
+\begin{caml_example*}{toplevel}
+let today () = (01,01,2000) (* an approximation *)
+module Account (M:MONEY) =
+ struct
+ type m = M.c
+ let m = new M.c
+ let zero = m 0.
+
+ class bank =
+ object (self)
+ val mutable balance = zero
+ method balance = balance
+ val mutable history = []
+ method private trace x = history <- x::history
+ method deposit x =
+ self#trace (Deposit x);
+ if zero#leq x then balance <- balance # plus x
+ else raise (Invalid_argument "deposit")
+ method withdraw x =
+ if x#leq balance then
+ (balance <- balance # plus (neg x); self#trace (Retrieval x); x)
+ else zero
+ method history = List.rev history
+ end
+
+ class type client_view =
+ object
+ method deposit : m -> unit
+ method history : m operation list
+ method withdraw : m -> m
+ method balance : m
+ end
+
+ class virtual check_client x =
+ let y = if (m 100.)#leq x then x
+ else raise (Failure "Insufficient initial deposit") in
+ object (self)
+ initializer self#deposit y
+ method virtual deposit: m -> unit
+ end
+
+ module Client (B : sig class bank : client_view end) =
+ struct
+ class account x : client_view =
+ object
+ inherit B.bank
+ inherit check_client x
+ end
+
+ let discount x =
+ let c = new account x in
+ if today() < (1998,10,30) then c # deposit (m 100.); c
+ end
+ end;;
+\end{caml_example*}
+This shows the use of modules to group several class definitions that can in
+fact be thought of as a single unit. This unit would be provided by a bank
+for both internal and external uses.
+This is implemented as a functor that abstracts over the currency so that
+the same code can be used to provide accounts in different currencies.
+
+The class "bank" is the {\em real} implementation of the bank account (it
+could have been inlined). This is the one that will be used for further
+extensions, refinements, etc. Conversely, the client will only be given the client view.
+\begin{caml_example*}{toplevel}
+module Euro_account = Account(Euro);;
+module Client = Euro_account.Client (Euro_account);;
+new Client.account (new Euro.c 100.);;
+\end{caml_example*}
+Hence, the clients do not have direct access to the "balance", nor the
+"history" of their own accounts. Their only way to change their balance is
+to deposit or withdraw money. It is important to give the clients
+a class and not just the ability to create accounts (such as the
+promotional "discount" account), so that they can
+personalize their account.
+For instance, a client may refine the "deposit" and "withdraw" methods
+so as to do his own financial bookkeeping, automatically. On the
+other hand, the function "discount" is given as such, with no
+possibility for further personalization.
+
+It is important to provide the client's view as a functor
+"Client" so that client accounts can still be built after a possible
+specialization of the "bank".
+The functor "Client" may remain unchanged and be passed
+the new definition to initialize a client's view of the extended account.
+\begin{caml_example*}{toplevel}
+module Investment_account (M : MONEY) =
+ struct
+ type m = M.c
+ module A = Account(M)
+
+ class bank =
+ object
+ inherit A.bank as super
+ method deposit x =
+ if (new M.c 1000.)#leq x then
+ print_string "Would you like to invest?";
+ super#deposit x
+ end
+
+ module Client = A.Client
+ end;;
+\end{caml_example*}
+\begin{caml_eval}
+module Euro_account = Investment_account (Euro);;
+module Client = Euro_account.Client (Euro_account);;
+new Client.account (new Euro.c 100.);;
+\end{caml_eval}
+The functor "Client" may also be redefined when some new features of the
+account can be given to the client.
+\begin{caml_example*}{toplevel}
+module Internet_account (M : MONEY) =
+ struct
+ type m = M.c
+ module A = Account(M)
+
+ class bank =
+ object
+ inherit A.bank
+ method mail s = print_string s
+ end
+
+ class type client_view =
+ object
+ method deposit : m -> unit
+ method history : m operation list
+ method withdraw : m -> m
+ method balance : m
+ method mail : string -> unit
+ end
+
+ module Client (B : sig class bank : client_view end) =
+ struct
+ class account x : client_view =
+ object
+ inherit B.bank
+ inherit A.check_client x
+ end
+ end
+ end;;
+\end{caml_example*}
+\begin{caml_eval}
+module Euro_account = Internet_account (Euro);;
+module Client = Euro_account.Client (Euro_account);;
+new Client.account (new Euro.c 100.);;
+\end{caml_eval}
+
+
+\section{Simple modules as classes}
+\pdfsection{Simple modules as classes}
+\label{ss:modules-as-classes}
+
+One may wonder whether it is possible to treat primitive types such as
+integers and strings as objects. Although this is usually uninteresting
+for integers or strings, there may be some situations where
+this is desirable. The class "money" above is such an example.
+We show here how to do it for strings.
+
+\subsection{Strings}
+\label{module:string}
+
+A naive definition of strings as objects could be:
+\begin{caml_example}{toplevel}
+class ostring s =
+ object
+ method get n = String.get s n
+ method print = print_string s
+ method escaped = new ostring (String.escaped s)
+ end;;
+\end{caml_example}
+However, the method "escaped" returns an object of the class "ostring",
+and not an object of the current class. Hence, if the class is further
+extended, the method "escaped" will only return an object of the parent
+class.
+\begin{caml_example}{toplevel}
+class sub_string s =
+ object
+ inherit ostring s
+ method sub start len = new sub_string (String.sub s start len)
+ end;;
+\end{caml_example}
+As seen in section \ref{ss:binary-methods}, the solution is to use
+functional update instead. We need to create an instance variable
+containing the representation "s" of the string.
+\begin{caml_example}{toplevel}
+class better_string s =
+ object
+ val repr = s
+ method get n = String.get repr n
+ method print = print_string repr
+ method escaped = {< repr = String.escaped repr >}
+ method sub start len = {< repr = String.sub s start len >}
+ end;;
+\end{caml_example}
+As shown in the inferred type, the methods "escaped" and "sub" now return
+objects of the same type as the one of the class.
+
+Another difficulty is the implementation of the method "concat".
+In order to concatenate a string with another string of the same class,
+one must be able to access the instance variable externally. Thus, a method
+"repr" returning s must be defined. Here is the correct definition of
+strings:
+\begin{caml_example}{toplevel}
+class ostring s =
+ object (self : 'mytype)
+ val repr = s
+ method repr = repr
+ method get n = String.get repr n
+ method print = print_string repr
+ method escaped = {< repr = String.escaped repr >}
+ method sub start len = {< repr = String.sub s start len >}
+ method concat (t : 'mytype) = {< repr = repr ^ t#repr >}
+ end;;
+\end{caml_example}
+Another constructor of the class string can be defined to return a new
+string of a given length:
+\begin{caml_example}{toplevel}
+class cstring n = ostring (String.make n ' ');;
+\end{caml_example}
+Here, exposing the representation of strings is probably harmless. We do
+could also hide the representation of strings as we hid the currency in the
+class "money" of section~\ref{ss:friends}.
+
+\subsubsection{Stacks}
+\label{module:stack}
+
+There is sometimes an alternative between using modules or classes for
+parametric data types.
+Indeed, there are situations when the two approaches are quite similar.
+For instance, a stack can be straightforwardly implemented as a class:
+\begin{caml_example}{toplevel}
+exception Empty;;
+class ['a] stack =
+ object
+ val mutable l = ([] : 'a list)
+ method push x = l <- x::l
+ method pop = match l with [] -> raise Empty | a::l' -> l <- l'; a
+ method clear = l <- []
+ method length = List.length l
+ end;;
+\end{caml_example}
+However, writing a method for iterating over a stack is more
+problematic. A method "fold" would have type
+"('b -> 'a -> 'b) -> 'b -> 'b". Here "'a" is the parameter of the stack.
+The parameter "'b" is not related to the class "'a stack" but to the
+argument that will be passed to the method "fold".
+%The intuition is that method "fold" should be polymorphic, i.e. of type
+%"All ('a) ('b -> 'a -> 'b) -> 'b -> 'b".
+A naive approach is to make "'b" an extra parameter of class "stack":
+\begin{caml_example}{toplevel}
+class ['a, 'b] stack2 =
+ object
+ inherit ['a] stack
+ method fold f (x : 'b) = List.fold_left f x l
+ end;;
+\end{caml_example}
+However, the method "fold" of a given object can only be
+applied to functions that all have the same type:
+\begin{caml_example}{toplevel}
+let s = new stack2;;
+s#fold ( + ) 0;;
+s;;
+\end{caml_example}
+A better solution is to use polymorphic methods, which were
+introduced in OCaml version 3.05. Polymorphic methods makes
+it possible to treat the type variable "'b" in the type of "fold" as
+universally quantified, giving "fold" the polymorphic type
+"Forall 'b. ('b -> 'a -> 'b) -> 'b -> 'b".
+An explicit type declaration on the method "fold" is required, since
+the type checker cannot infer the polymorphic type by itself.
+\begin{caml_example}{toplevel}
+class ['a] stack3 =
+ object
+ inherit ['a] stack
+ method fold : 'b. ('b -> 'a -> 'b) -> 'b -> 'b
+ = fun f x -> List.fold_left f x l
+ end;;
+\end{caml_example}
+
+% However, the nice correspondence between the implementations of stacks as
+% modules or classes is a very particular case.
+
+% XXX Maps
+
+\subsection{Hashtbl}
+\label{module:hashtbl}
+
+A simplified version of object-oriented hash tables should have the
+following class type.
+\begin{caml_example}{toplevel}
+class type ['a, 'b] hash_table =
+ object
+ method find : 'a -> 'b
+ method add : 'a -> 'b -> unit
+ end;;
+\end{caml_example}
+A simple implementation, which is quite reasonable for small hash tables is
+to use an association list:
+\begin{caml_example}{toplevel}
+class ['a, 'b] small_hashtbl : ['a, 'b] hash_table =
+ object
+ val mutable table = []
+ method find key = List.assoc key table
+ method add key valeur = table <- (key, valeur) :: table
+ end;;
+\end{caml_example}
+A better implementation, and one that scales up better, is to use a
+true hash table\ldots\ whose elements are small hash tables!
+\begin{caml_example}{toplevel}
+class ['a, 'b] hashtbl size : ['a, 'b] hash_table =
+ object (self)
+ val table = Array.init size (fun i -> new small_hashtbl)
+ method private hash key =
+ (Hashtbl.hash key) mod (Array.length table)
+ method find key = table.(self#hash key) # find key
+ method add key = table.(self#hash key) # add key
+ end;;
+\end{caml_example}
+
+% problem
+
+% solution
+
+\subsection{Sets}
+\label{module:set}
+
+Implementing sets leads to another difficulty. Indeed, the method
+"union" needs to be able to access the internal representation of
+another object of the same class.
+
+This is another instance of friend functions as seen in section
+\ref{ss:friends}. Indeed, this is the same mechanism used in the module
+"Set" in the absence of objects.
+
+In the object-oriented version of sets, we only need to add an additional
+method "tag" to return the representation of a set. Since sets are
+parametric in the type of elements, the method "tag" has a parametric type
+"'a tag", concrete within
+the module definition but abstract in its signature.
+From outside, it will then be guaranteed that two objects with a method "tag"
+of the same type will share the same representation.
+\begin{caml_example*}{toplevel}
+module type SET =
+ sig
+ type 'a tag
+ class ['a] c :
+ object ('b)
+ method is_empty : bool
+ method mem : 'a -> bool
+ method add : 'a -> 'b
+ method union : 'b -> 'b
+ method iter : ('a -> unit) -> unit
+ method tag : 'a tag
+ end
+ end;;
+module Set : SET =
+ struct
+ let rec merge l1 l2 =
+ match l1 with
+ [] -> l2
+ | h1 :: t1 ->
+ match l2 with
+ [] -> l1
+ | h2 :: t2 ->
+ if h1 < h2 then h1 :: merge t1 l2
+ else if h1 > h2 then h2 :: merge l1 t2
+ else merge t1 l2
+ type 'a tag = 'a list
+ class ['a] c =
+ object (_ : 'b)
+ val repr = ([] : 'a list)
+ method is_empty = (repr = [])
+ method mem x = List.exists (( = ) x) repr
+ method add x = {< repr = merge [x] repr >}
+ method union (s : 'b) = {< repr = merge repr s#tag >}
+ method iter (f : 'a -> unit) = List.iter f repr
+ method tag = repr
+ end
+ end;;
+\end{caml_example*}
+
+\section{The subject/observer pattern}
+\pdfsection{The subject/observer pattern}
+\label{ss:subject-observer}
+
+The following example, known as the subject/observer pattern, is often
+presented in the literature as a difficult inheritance problem with
+inter-connected classes.
+The general pattern amounts to the definition a pair of two
+classes that recursively interact with one another.
+
+The class "observer" has a distinguished method "notify" that requires
+two arguments, a subject and an event to execute an action.
+\begin{caml_example}{toplevel}
+class virtual ['subject, 'event] observer =
+ object
+ method virtual notify : 'subject -> 'event -> unit
+ end;;
+\end{caml_example}
+The class "subject" remembers a list of observers in an instance variable,
+and has a distinguished method "notify_observers" to broadcast the message
+"notify" to all observers with a particular event "e".
+\begin{caml_example}{toplevel}
+class ['observer, 'event] subject =
+ object (self)
+ val mutable observers = ([]:'observer list)
+ method add_observer obs = observers <- (obs :: observers)
+ method notify_observers (e : 'event) =
+ List.iter (fun x -> x#notify self e) observers
+ end;;
+\end{caml_example}
+The difficulty usually lies in defining instances of the pattern above
+by inheritance. This can be done in a natural and obvious manner in
+OCaml, as shown on the following example manipulating windows.
+\begin{caml_example}{toplevel}
+type event = Raise | Resize | Move;;
+let string_of_event = function
+ Raise -> "Raise" | Resize -> "Resize" | Move -> "Move";;
+let count = ref 0;;
+class ['observer] window_subject =
+ let id = count := succ !count; !count in
+ object (self)
+ inherit ['observer, event] subject
+ val mutable position = 0
+ method identity = id
+ method move x = position <- position + x; self#notify_observers Move
+ method draw = Printf.printf "{Position = %d}\n" position;
+ end;;
+class ['subject] window_observer =
+ object
+ inherit ['subject, event] observer
+ method notify s e = s#draw
+ end;;
+\end{caml_example}
+As can be expected, the type of "window" is recursive.
+\begin{caml_example}{toplevel}
+let window = new window_subject;;
+\end{caml_example}
+However, the two classes of "window_subject" and "window_observer" are not
+mutually recursive.
+\begin{caml_example}{toplevel}
+let window_observer = new window_observer;;
+window#add_observer window_observer;;
+window#move 1;;
+\end{caml_example}
+
+Classes "window_observer" and "window_subject" can still be extended by
+inheritance. For instance, one may enrich the "subject" with new
+behaviors and refine the behavior of the observer.
+\begin{caml_example}{toplevel}
+class ['observer] richer_window_subject =
+ object (self)
+ inherit ['observer] window_subject
+ val mutable size = 1
+ method resize x = size <- size + x; self#notify_observers Resize
+ val mutable top = false
+ method raise = top <- true; self#notify_observers Raise
+ method draw = Printf.printf "{Position = %d; Size = %d}\n" position size;
+ end;;
+class ['subject] richer_window_observer =
+ object
+ inherit ['subject] window_observer as super
+ method notify s e = if e <> Raise then s#raise; super#notify s e
+ end;;
+\end{caml_example}
+We can also create a different kind of observer:
+\begin{caml_example}{toplevel}
+class ['subject] trace_observer =
+ object
+ inherit ['subject, event] observer
+ method notify s e =
+ Printf.printf
+ "<Window %d <== %s>\n" s#identity (string_of_event e)
+ end;;
+\end{caml_example}
+and attach several observers to the same object:
+\begin{caml_example}{toplevel}
+let window = new richer_window_subject;;
+window#add_observer (new richer_window_observer);;
+window#add_observer (new trace_observer);;
+window#move 1; window#resize 2;;
+\end{caml_example}
+
+%\subsection{Classes used as modules with inheritance}
+%
+% to be filled for next release...
+%
+% an example of stateless objects used to provide inheritance in modules
+%
+
+
+% LocalWords: objectexamples bsection init caml val int Oo succ incr ref
+% LocalWords: typecheck leq bool cp eval sig struct ABSPOINT Abspoint iter neg
+% LocalWords: accu mem rec repr Euro euro ccp inlined ostring len concat OCaml
--- /dev/null
+\chapter{The core language} \label{c:core-xamples}
+\pdfchapterfold{-9}{Tutorial: The core language}
+%HEVEA\cutname{coreexamples.html}
+
+This part of the manual is a tutorial introduction to the
+OCaml language. A good familiarity with programming in a conventional
+languages (say, C or Java) is assumed, but no prior exposure to
+functional languages is required. The present chapter introduces the
+core language. Chapter~\ref{c:moduleexamples} deals with the
+module system, chapter~\ref{c:objectexamples} with the
+object-oriented features, chapter~\ref{c:labl-examples} with
+extensions to the core language (labeled arguments and polymorphic
+variants), and chapter~\ref{c:advexamples} gives some advanced examples.
+
+\section{Basics}
+\pdfsection{Basics}
+
+For this overview of OCaml, we use the interactive system, which
+is started by running "ocaml" from the Unix shell, or by launching the
+"OCamlwin.exe" application under Windows. This tutorial is presented
+as the transcript of a session with the interactive system:
+lines starting with "#" represent user input; the system responses are
+printed below, without a leading "#".
+
+Under the interactive system, the user types OCaml phrases terminated
+by ";;" in response to the "#" prompt, and the system compiles them
+on the fly, executes them, and prints the outcome of evaluation.
+Phrases are either simple expressions, or "let" definitions of
+identifiers (either values or functions).
+\begin{caml_example}{toplevel}
+1+2*3;;
+let pi = 4.0 *. atan 1.0;;
+let square x = x *. x;;
+square (sin pi) +. square (cos pi);;
+\end{caml_example}
+The OCaml system computes both the value and the type for
+each phrase. Even function parameters need no explicit type declaration:
+the system infers their types from their usage in the
+function. Notice also that integers and floating-point numbers are
+distinct types, with distinct operators: "+" and "*" operate on
+integers, but "+." and "*." operate on floats.
+\begin{caml_example}{toplevel}[error]
+1.0 * 2;;
+\end{caml_example}
+
+Recursive functions are defined with the "let rec" binding:
+\begin{caml_example}{toplevel}
+let rec fib n =
+ if n < 2 then n else fib (n-1) + fib (n-2);;
+fib 10;;
+\end{caml_example}
+
+\section{Data types}
+\pdfsection{Data types}
+
+In addition to integers and floating-point numbers, OCaml offers the
+usual basic data types: booleans, characters, and immutable character strings.
+\begin{caml_example}{toplevel}
+(1 < 2) = false;;
+'a';;
+"Hello world";;
+\end{caml_example}
+
+Predefined data structures include tuples, arrays, and lists. There are also
+general mechanisms for defining your own data structures, such as records and
+variants, which will be covered in more detail later; for now, we concentrate
+on lists. Lists are either given in extension as a bracketed list of
+semicolon-separated elements, or built from the empty list "[]"
+(pronounce ``nil'') by adding elements in front using the "::"
+(``cons'') operator.
+\begin{caml_example}{toplevel}
+let l = ["is"; "a"; "tale"; "told"; "etc."];;
+"Life" :: l;;
+\end{caml_example}
+As with all other OCaml data structures, lists do not need to be
+explicitly allocated and deallocated from memory: all memory
+management is entirely automatic in OCaml. Similarly, there is no
+explicit handling of pointers: the OCaml compiler silently introduces
+pointers where necessary.
+
+As with most OCaml data structures, inspecting and destructuring lists
+is performed by pattern-matching. List patterns have exactly the same
+form as list expressions, with identifiers representing unspecified
+parts of the list. As an example, here is insertion sort on a list:
+\begin{caml_example}{toplevel}
+let rec sort lst =
+ match lst with
+ [] -> []
+ | head :: tail -> insert head (sort tail)
+and insert elt lst =
+ match lst with
+ [] -> [elt]
+ | head :: tail -> if elt <= head then elt :: lst else head :: insert elt tail
+;;
+sort l;;
+\end{caml_example}
+
+The type inferred for "sort", "'a list -> 'a list", means that "sort"
+can actually apply to lists of any type, and returns a list of the
+same type. The type "'a" is a {\em type variable}, and stands for any
+given type. The reason why "sort" can apply to lists of any type is
+that the comparisons ("=", "<=", etc.) are {\em polymorphic} in OCaml:
+they operate between any two values of the same type. This makes
+"sort" itself polymorphic over all list types.
+\begin{caml_example}{toplevel}
+sort [6;2;5;3];;
+sort [3.14; 2.718];;
+\end{caml_example}
+
+The "sort" function above does not modify its input list: it builds
+and returns a new list containing the same elements as the input list,
+in ascending order. There is actually no way in OCaml to modify
+a list in-place once it is built: we say that lists are {\em immutable}
+data structures. Most OCaml data structures are immutable, but a few
+(most notably arrays) are {\em mutable}, meaning that they can be
+modified in-place at any time.
+
+The OCaml notation for the type of a function with multiple arguments is \\
+"arg1_type -> arg2_type -> ... -> return_type". For example,
+the type inferred for "insert", "'a -> 'a list -> 'a list", means that "insert"
+takes two arguments, an element of any type "'a" and a list with elements of
+the same type "'a" and returns a list of the same type.
+\section{Functions as values}
+\pdfsection{Functions as values}
+
+OCaml is a functional language: functions in the full mathematical
+sense are supported and can be passed around freely just as any other
+piece of data. For instance, here is a "deriv" function that takes any
+float function as argument and returns an approximation of its
+derivative function:
+\begin{caml_example}{toplevel}
+let deriv f dx = function x -> (f (x +. dx) -. f x) /. dx;;
+let sin' = deriv sin 1e-6;;
+sin' pi;;
+\end{caml_example}
+Even function composition is definable:
+\begin{caml_example}{toplevel}
+let compose f g = function x -> f (g x);;
+let cos2 = compose square cos;;
+\end{caml_example}
+
+Functions that take other functions as arguments are called
+``functionals'', or ``higher-order functions''. Functionals are
+especially useful to provide iterators or similar generic operations
+over a data structure. For instance, the standard OCaml library
+provides a "List.map" functional that applies a given function to each
+element of a list, and returns the list of the results:
+\begin{caml_example}{toplevel}
+List.map (function n -> n * 2 + 1) [0;1;2;3;4];;
+\end{caml_example}
+This functional, along with a number of other list and array
+functionals, is predefined because it is often useful, but there is
+nothing magic with it: it can easily be defined as follows.
+\begin{caml_example}{toplevel}
+let rec map f l =
+ match l with
+ [] -> []
+ | hd :: tl -> f hd :: map f tl;;
+\end{caml_example}
+
+\section{Records and variants}
+\pdfsection{Records and variants}
+\label{s:tut-recvariants}
+
+User-defined data structures include records and variants. Both are
+defined with the "type" declaration. Here, we declare a record type to
+represent rational numbers.
+\begin{caml_example}{toplevel}
+type ratio = {num: int; denom: int};;
+let add_ratio r1 r2 =
+ {num = r1.num * r2.denom + r2.num * r1.denom;
+ denom = r1.denom * r2.denom};;
+add_ratio {num=1; denom=3} {num=2; denom=5};;
+\end{caml_example}
+Record fields can also be accessed through pattern-matching:
+\begin{caml_example}{toplevel}
+let integer_part r =
+ match r with
+ {num=num; denom=denom} -> num / denom;;
+\end{caml_example}
+Since there is only one case in this pattern matching, it
+is safe to expand directly the argument "r" in a record pattern:
+\begin{caml_example}{toplevel}
+let integer_part {num=num; denom=denom} = num / denom;;
+\end{caml_example}
+Unneeded fields can be omitted:
+\begin{caml_example}{toplevel}
+let get_denom {denom=denom} = denom;;
+\end{caml_example}
+Optionally, missing fields can be made explicit by ending the list of
+fields with a trailing wildcard "_"::
+\begin{caml_example}{toplevel}
+let get_num {num=num; _ } = num;;
+\end{caml_example}
+When both sides of the "=" sign are the same, it is possible to avoid
+repeating the field name by eliding the "=field" part:
+\begin{caml_example}{toplevel}
+let integer_part {num; denom} = num / denom;;
+\end{caml_example}
+This short notation for fields also works when constructing records:
+\begin{caml_example}{toplevel}
+let ratio num denom = {num; denom};;
+\end{caml_example}
+At last, it is possible to update few fields of a record at once:
+\begin{caml_example}{toplevel}
+ let integer_product integer ratio = { ratio with num = integer * ratio.num };;
+\end{caml_example}
+With this functional update notation, the record on the left-hand side
+of "with" is copied except for the fields on the right-hand side which
+are updated.
+
+The declaration of a variant type lists all possible forms for values
+of that type. Each case is identified by a name, called a constructor,
+which serves both for constructing values of the variant type and
+inspecting them by pattern-matching. Constructor names are capitalized
+to distinguish them from variable names (which must start with a
+lowercase letter). For instance, here is a variant
+type for doing mixed arithmetic (integers and floats):
+\begin{caml_example}{toplevel}
+type number = Int of int | Float of float | Error;;
+\end{caml_example}
+This declaration expresses that a value of type "number" is either an
+integer, a floating-point number, or the constant "Error" representing
+the result of an invalid operation (e.g. a division by zero).
+
+Enumerated types are a special case of variant types, where all
+alternatives are constants:
+\begin{caml_example}{toplevel}
+type sign = Positive | Negative;;
+let sign_int n = if n >= 0 then Positive else Negative;;
+\end{caml_example}
+
+To define arithmetic operations for the "number" type, we use
+pattern-matching on the two numbers involved:
+\begin{caml_example}{toplevel}
+let add_num n1 n2 =
+ match (n1, n2) with
+ (Int i1, Int i2) ->
+ (* Check for overflow of integer addition *)
+ if sign_int i1 = sign_int i2 && sign_int (i1 + i2) <> sign_int i1
+ then Float(float i1 +. float i2)
+ else Int(i1 + i2)
+ | (Int i1, Float f2) -> Float(float i1 +. f2)
+ | (Float f1, Int i2) -> Float(f1 +. float i2)
+ | (Float f1, Float f2) -> Float(f1 +. f2)
+ | (Error, _) -> Error
+ | (_, Error) -> Error;;
+add_num (Int 123) (Float 3.14159);;
+\end{caml_example}
+
+Another interesting example of variant type is the built-in
+"'a option" type which represents either a value of type "'a" or an
+absence of value:
+\begin{caml_example}{toplevel}
+type 'a option = Some of 'a | None;;
+\end{caml_example}
+This type is particularly useful when defining function that can
+fail in common situations, for instance
+\begin{caml_example}{toplevel}
+let safe_square_root x = if x > 0. then Some(sqrt x) else None;;
+\end{caml_example}
+
+The most common usage of variant types is to describe recursive data
+structures. Consider for example the type of binary trees:
+\begin{caml_example}{toplevel}
+type 'a btree = Empty | Node of 'a * 'a btree * 'a btree;;
+\end{caml_example}
+This definition reads as follows: a binary tree containing values of
+type "'a" (an arbitrary type) is either empty, or is a node containing
+one value of type "'a" and two subtrees also containing values of type
+"'a", that is, two "'a btree".
+
+Operations on binary trees are naturally expressed as recursive functions
+following the same structure as the type definition itself. For
+instance, here are functions performing lookup and insertion in
+ordered binary trees (elements increase from left to right):
+\begin{caml_example}{toplevel}
+let rec member x btree =
+ match btree with
+ Empty -> false
+ | Node(y, left, right) ->
+ if x = y then true else
+ if x < y then member x left else member x right;;
+let rec insert x btree =
+ match btree with
+ Empty -> Node(x, Empty, Empty)
+ | Node(y, left, right) ->
+ if x <= y then Node(y, insert x left, right)
+ else Node(y, left, insert x right);;
+\end{caml_example}
+
+
+\subsection{Record and variant disambiguation}
+( This subsection can be skipped on the first reading )
+
+Astute readers may have wondered what happens when two or more record
+fields or constructors share the same name
+
+\begin{caml_example*}{toplevel}
+type first_record = { x:int; y:int; z:int }
+type middle_record = { x:int; z:int }
+type last_record = { x:int };;
+type first_variant = A | B | C
+type last_variant = A;;
+\end{caml_example*}
+
+The answer is that when confronted with multiple options, OCaml tries to
+use locally available information to disambiguate between the various fields
+and constructors. First, if the type of the record or variant is known,
+OCaml can pick unambiguously the corresponding field or constructor.
+For instance:
+
+\begin{caml_example}{toplevel}
+let look_at_x_then_z (r:first_record) =
+ let x = r.x in
+ x + r.z;;
+let permute (x:first_variant) = match x with
+ | A -> (B:first_variant)
+ | B -> A
+ | C -> C;;
+type wrapped = First of first_record
+let f (First r) = r, r.x;;
+\end{caml_example}
+
+In the first example, "(r:first_record)" is an explicit annotation
+telling OCaml that the type of "r" is "first_record". With this
+annotation, Ocaml knows that "r.x" refers to the "x" field of the first
+record type. Similarly, the type annotation in the second example makes
+it clear to OCaml that the constructors "A", "B" and "C" come from the
+first variant type. Contrarily, in the last example, OCaml has inferred
+by itself that the type of "r" can only be "first_record" and there are
+no needs for explicit type annotations.
+
+Those explicit type annotations can in fact be used anywhere.
+Most of the time they are unnecessary, but they are useful to guide
+disambiguation, to debug unexpected type errors, or combined with some
+of the more advanced features of OCaml described in later chapters.
+
+Secondly, for records, OCaml can also deduce the right record type by
+looking at the whole set of fields used in a expression or pattern:
+\begin{caml_example}{toplevel}
+let project_and_rotate {x;y; _ } = { x= - y; y = x ; z = 0} ;;
+\end{caml_example}
+Since the fields "x" and "y" can only appear simultaneously in the first
+record type, OCaml infers that the type of "project_and_rotate" is
+"first_record -> first_record".
+
+In last resort, if there is not enough information to disambiguate between
+different fields or constructors, Ocaml picks the last defined type
+amongst all locally valid choices:
+
+\begin{caml_example}{toplevel}
+let look_at_xz {x;z} = x;;
+\end{caml_example}
+
+Here, OCaml has inferred that the possible choices for the type of
+"{x;z}" are "first_record" and "middle_record", since the type
+"last_record" has no field "z". Ocaml then picks the type "middle_record"
+as the last defined type between the two possibilities.
+
+Beware that this last resort disambiguation is local: once Ocaml has
+chosen a disambiguation, it sticks to this choice, even if it leads to
+an ulterior type error:
+
+\begin{caml_example}{toplevel}[error]
+let look_at_x_then_y r =
+ let x = r.x in (* Ocaml deduces [r: last_record] *)
+ x + r.y;;
+let is_a_or_b x = match x with
+ | A -> true (* OCaml infers [x: last_variant] *)
+ | B -> true;;
+\end{caml_example}
+
+Moreover, being the last defined type is a quite unstable position that
+may change surreptitiously after adding or moving around a type
+definition, or after opening a module (see chapter \ref{c:moduleexamples}).
+Consequently, adding explicit type annotations to guide disambiguation is
+more robust than relying on the last defined type disambiguation.
+
+\section{Imperative features}
+\pdfsection{Imperative features}
+
+Though all examples so far were written in purely applicative style,
+OCaml is also equipped with full imperative features. This includes the
+usual "while" and "for" loops, as well as mutable data structures such
+as arrays. Arrays are either created by listing semicolon-separated element
+values between "[|" and "|]" brackets, or allocated and initialized with the
+"Array.make" function, then filled up later by assignments. For instance, the
+function below sums two vectors (represented as float arrays) componentwise.
+\begin{caml_example}{toplevel}
+let add_vect v1 v2 =
+ let len = min (Array.length v1) (Array.length v2) in
+ let res = Array.make len 0.0 in
+ for i = 0 to len - 1 do
+ res.(i) <- v1.(i) +. v2.(i)
+ done;
+ res;;
+add_vect [| 1.0; 2.0 |] [| 3.0; 4.0 |];;
+\end{caml_example}
+
+Record fields can also be modified by assignment, provided they are
+declared "mutable" in the definition of the record type:
+\begin{caml_example}{toplevel}
+type mutable_point = { mutable x: float; mutable y: float };;
+let translate p dx dy =
+ p.x <- p.x +. dx; p.y <- p.y +. dy;;
+let mypoint = { x = 0.0; y = 0.0 };;
+translate mypoint 1.0 2.0;;
+mypoint;;
+\end{caml_example}
+
+OCaml has no built-in notion of variable -- identifiers whose current
+value can be changed by assignment. (The "let" binding is not an
+assignment, it introduces a new identifier with a new scope.)
+However, the standard library provides references, which are mutable
+indirection cells, with operators "!" to fetch
+the current contents of the reference and ":=" to assign the contents.
+Variables can then be emulated by "let"-binding a reference. For
+instance, here is an in-place insertion sort over arrays:
+\begin{caml_example}{toplevel}
+let insertion_sort a =
+ for i = 1 to Array.length a - 1 do
+ let val_i = a.(i) in
+ let j = ref i in
+ while !j > 0 && val_i < a.(!j - 1) do
+ a.(!j) <- a.(!j - 1);
+ j := !j - 1
+ done;
+ a.(!j) <- val_i
+ done;;
+\end{caml_example}
+
+References are also useful to write functions that maintain a current
+state between two calls to the function. For instance, the following
+pseudo-random number generator keeps the last returned number in a
+reference:
+\begin{caml_example}{toplevel}
+let current_rand = ref 0;;
+let random () =
+ current_rand := !current_rand * 25713 + 1345;
+ !current_rand;;
+\end{caml_example}
+
+Again, there is nothing magical with references: they are implemented as
+a single-field mutable record, as follows.
+\begin{caml_example}{toplevel}
+type 'a ref = { mutable contents: 'a };;
+let ( ! ) r = r.contents;;
+let ( := ) r newval = r.contents <- newval;;
+\end{caml_example}
+
+In some special cases, you may need to store a polymorphic function in
+a data structure, keeping its polymorphism. Doing this requires
+user-provided type annotations, since polymorphism is only introduced
+automatically for global definitions. However, you can explicitly give
+polymorphic types to record fields.
+\begin{caml_example}{toplevel}
+type idref = { mutable id: 'a. 'a -> 'a };;
+let r = {id = fun x -> x};;
+let g s = (s.id 1, s.id true);;
+r.id <- (fun x -> print_string "called id\n"; x);;
+g r;;
+\end{caml_example}
+
+\section{Exceptions}
+\pdfsection{Exceptions}
+
+OCaml provides exceptions for signalling and handling exceptional
+conditions. Exceptions can also be used as a general-purpose non-local
+control structure, although this should not be overused since it can
+make the code harder to understand. Exceptions are declared with the
+"exception" construct, and signalled with the "raise" operator. For instance,
+the function below for taking the head of a list uses an exception to
+signal the case where an empty list is given.
+\begin{caml_example}{toplevel}
+exception Empty_list;;
+let head l =
+ match l with
+ [] -> raise Empty_list
+ | hd :: tl -> hd;;
+head [1;2];;
+head [];;
+\end{caml_example}
+
+Exceptions are used throughout the standard library to signal cases
+where the library functions cannot complete normally. For instance,
+the "List.assoc" function, which returns the data associated with a
+given key in a list of (key, data) pairs, raises the predefined
+exception "Not_found" when the key does not appear in the list:
+\begin{caml_example}{toplevel}
+List.assoc 1 [(0, "zero"); (1, "one")];;
+List.assoc 2 [(0, "zero"); (1, "one")];;
+\end{caml_example}
+
+Exceptions can be trapped with the "try"\ldots"with" construct:
+\begin{caml_example}{toplevel}
+let name_of_binary_digit digit =
+ try
+ List.assoc digit [0, "zero"; 1, "one"]
+ with Not_found ->
+ "not a binary digit";;
+name_of_binary_digit 0;;
+name_of_binary_digit (-1);;
+\end{caml_example}
+
+The "with" part does pattern matching on the
+exception value with the same syntax and behavior as "match". Thus,
+several exceptions can be caught by one
+"try"\ldots"with" construct. Also, finalization can be performed by
+trapping all exceptions, performing the finalization, then re-raising
+the exception:
+\begin{caml_example}{toplevel}
+let temporarily_set_reference ref newval funct =
+ let oldval = !ref in
+ try
+ ref := newval;
+ let res = funct () in
+ ref := oldval;
+ res
+ with x ->
+ ref := oldval;
+ raise x;;
+\end{caml_example}
+
+\section{Symbolic processing of expressions}
+\pdfsection{Symbolic processing of expressions}
+
+We finish this introduction with a more complete example
+representative of the use of OCaml for symbolic processing: formal
+manipulations of arithmetic expressions containing variables. The
+following variant type describes the expressions we shall manipulate:
+\begin{caml_example}{toplevel}
+type expression =
+ Const of float
+ | Var of string
+ | Sum of expression * expression (* e1 + e2 *)
+ | Diff of expression * expression (* e1 - e2 *)
+ | Prod of expression * expression (* e1 * e2 *)
+ | Quot of expression * expression (* e1 / e2 *)
+;;
+\end{caml_example}
+
+We first define a function to evaluate an expression given an
+environment that maps variable names to their values. For simplicity,
+the environment is represented as an association list.
+\begin{caml_example}{toplevel}
+exception Unbound_variable of string;;
+let rec eval env exp =
+ match exp with
+ Const c -> c
+ | Var v ->
+ (try List.assoc v env with Not_found -> raise (Unbound_variable v))
+ | Sum(f, g) -> eval env f +. eval env g
+ | Diff(f, g) -> eval env f -. eval env g
+ | Prod(f, g) -> eval env f *. eval env g
+ | Quot(f, g) -> eval env f /. eval env g;;
+eval [("x", 1.0); ("y", 3.14)] (Prod(Sum(Var "x", Const 2.0), Var "y"));;
+\end{caml_example}
+
+Now for a real symbolic processing, we define the derivative of an
+expression with respect to a variable "dv":
+\begin{caml_example}{toplevel}
+let rec deriv exp dv =
+ match exp with
+ Const c -> Const 0.0
+ | Var v -> if v = dv then Const 1.0 else Const 0.0
+ | Sum(f, g) -> Sum(deriv f dv, deriv g dv)
+ | Diff(f, g) -> Diff(deriv f dv, deriv g dv)
+ | Prod(f, g) -> Sum(Prod(f, deriv g dv), Prod(deriv f dv, g))
+ | Quot(f, g) -> Quot(Diff(Prod(deriv f dv, g), Prod(f, deriv g dv)),
+ Prod(g, g))
+;;
+deriv (Quot(Const 1.0, Var "x")) "x";;
+\end{caml_example}
+
+\section{Pretty-printing}
+\pdfsection{Pretty-printing}
+
+As shown in the examples above, the internal representation (also
+called {\em abstract syntax\/}) of expressions quickly becomes hard to
+read and write as the expressions get larger. We need a printer and a
+parser to go back and forth between the abstract syntax and the {\em
+concrete syntax}, which in the case of expressions is the familiar
+algebraic notation (e.g. "2*x+1").
+
+For the printing function, we take into account the usual precedence
+rules (i.e. "*" binds tighter than "+") to avoid printing unnecessary
+parentheses. To this end, we maintain the current operator precedence
+and print parentheses around an operator only if its precedence is
+less than the current precedence.
+\begin{caml_example}{toplevel}
+let print_expr exp =
+ (* Local function definitions *)
+ let open_paren prec op_prec =
+ if prec > op_prec then print_string "(" in
+ let close_paren prec op_prec =
+ if prec > op_prec then print_string ")" in
+ let rec print prec exp = (* prec is the current precedence *)
+ match exp with
+ Const c -> print_float c
+ | Var v -> print_string v
+ | Sum(f, g) ->
+ open_paren prec 0;
+ print 0 f; print_string " + "; print 0 g;
+ close_paren prec 0
+ | Diff(f, g) ->
+ open_paren prec 0;
+ print 0 f; print_string " - "; print 1 g;
+ close_paren prec 0
+ | Prod(f, g) ->
+ open_paren prec 2;
+ print 2 f; print_string " * "; print 2 g;
+ close_paren prec 2
+ | Quot(f, g) ->
+ open_paren prec 2;
+ print 2 f; print_string " / "; print 3 g;
+ close_paren prec 2
+ in print 0 exp;;
+let e = Sum(Prod(Const 2.0, Var "x"), Const 1.0);;
+print_expr e; print_newline ();;
+print_expr (deriv e "x"); print_newline ();;
+\end{caml_example}
+
+%%%%%%%%%%% Should be moved to the camlp4 documentation.
+%% Parsing (transforming concrete syntax into abstract syntax) is usually
+%% more delicate. OCaml offers several tools to help write parsers:
+%% on the one hand, OCaml versions of the lexer generator Lex and the
+%% parser generator Yacc (see chapter~\ref{c:ocamlyacc}), which handle
+%% LALR(1) languages using push-down automata; on the other hand, a
+%% predefined type of streams (of characters or tokens) and
+%% pattern-matching over streams, which facilitate the writing of
+%% recursive-descent parsers for LL(1) languages. An example using
+%% "ocamllex" and "ocamlyacc" is given in
+%% chapter~\ref{c:ocamlyacc}. Here, we will use stream parsers.
+%% The syntactic support for stream parsers is provided by the Camlp4
+%% preprocessor, which can be loaded into the interactive toplevel via
+%% the "#load" directives below.
+%%
+%% \begin{caml_example}
+%% #load "dynlink.cma";;
+%% #load "camlp4o.cma";;
+%% open Genlex;;
+%% let lexer = make_lexer ["("; ")"; "+"; "-"; "*"; "/"];;
+%% \end{caml_example}
+%% For the lexical analysis phase (transformation of the input text into
+%% a stream of tokens), we use a ``generic'' lexer provided in the
+%% standard library module "Genlex". The "make_lexer" function takes a
+%% list of keywords and returns a lexing function that ``tokenizes'' an
+%% input stream of characters. Tokens are either identifiers, keywords,
+%% or literals (integer, floats, characters, strings). Whitespace and
+%% comments are skipped.
+%% \begin{caml_example}
+%% let token_stream = lexer (Stream.of_string "1.0 +x");;
+%% Stream.next token_stream;;
+%% Stream.next token_stream;;
+%% Stream.next token_stream;;
+%% \end{caml_example}
+%%
+%% The parser itself operates by pattern-matching on the stream of
+%% tokens. As usual with recursive descent parsers, we use several
+%% intermediate parsing functions to reflect the precedence and
+%% associativity of operators. Pattern-matching over streams is more
+%% powerful than on regular data structures, as it allows recursive calls
+%% to parsing functions inside the patterns, for matching sub-components of
+%% the input stream. See the Camlp4 documentation for more details.
+%%
+%% %Already said above
+%% %In order to use stream parsers at toplevel, we must first load the
+%% %"camlp4" preprocessor.
+%% %\begin{caml_example}
+%% %#load"camlp4o.cma";;
+%% %\end{caml_example}
+%% %Then we are ready to define our parser.
+%% \begin{caml_example}{toplevel}
+%% let rec parse_expr = parser
+%% [< e1 = parse_mult; e = parse_more_adds e1 >] -> e
+%% and parse_more_adds e1 = parser
+%% [< 'Kwd "+"; e2 = parse_mult; e = parse_more_adds (Sum(e1, e2)) >] -> e
+%% | [< 'Kwd "-"; e2 = parse_mult; e = parse_more_adds (Diff(e1, e2)) >] -> e
+%% | [< >] -> e1
+%% and parse_mult = parser
+%% [< e1 = parse_simple; e = parse_more_mults e1 >] -> e
+%% and parse_more_mults e1 = parser
+%% [< 'Kwd "*"; e2 = parse_simple; e = parse_more_mults (Prod(e1, e2)) >] -> e
+%% | [< 'Kwd "/"; e2 = parse_simple; e = parse_more_mults (Quot(e1, e2)) >] -> e
+%% | [< >] -> e1
+%% and parse_simple = parser
+%% [< 'Ident s >] -> Var s
+%% | [< 'Int i >] -> Const(float i)
+%% | [< 'Float f >] -> Const f
+%% | [< 'Kwd "("; e = parse_expr; 'Kwd ")" >] -> e;;
+%% let parse_expression = parser [< e = parse_expr; _ = Stream.empty >] -> e;;
+%% \end{caml_example}
+%%
+%% Composing the lexer and parser, we finally obtain a function to read
+%% an expression from a character string:
+%% \begin{caml_example}
+%% let read_expression s = parse_expression (lexer (Stream.of_string s));;
+%% read_expression "2*(x+y)";;
+%% \end{caml_example}
+%% A small puzzle: why do we get different results in the following two
+%% examples?
+%% \begin{caml_example}
+%% read_expression "x - 1";;
+%% read_expression "x-1";;
+%% \end{caml_example}
+%% Answer: the generic lexer provided by "Genlex" recognizes negative
+%% integer literals as one integer token. Hence, "x-1" is read as
+%% the token "Ident \"x\"" followed by the token "Int(-1)"; this sequence
+%% does not match any of the parser rules. On the other hand,
+%% the second space in "x - 1" causes the lexer to return the three
+%% expected tokens: "Ident \"x\"", then "Kwd \"-\"", then "Int(1)".
+
+\section{Standalone OCaml programs}
+\pdfsection{Standalone OCaml programs}
+
+All examples given so far were executed under the interactive system.
+OCaml code can also be compiled separately and executed
+non-interactively using the batch compilers "ocamlc" and "ocamlopt".
+The source code must be put in a file with extension ".ml". It
+consists of a sequence of phrases, which will be evaluated at runtime
+in their order of appearance in the source file. Unlike in interactive
+mode, types and values are not printed automatically; the program must
+call printing functions explicitly to produce some output. The ";;" used
+in the interactive examples is not required in
+source files created for use with OCaml compilers, but can be helpful
+to mark the end of a top-level expression unambiguously even when
+there are syntax errors.
+Here is a
+sample standalone program to print Fibonacci numbers:
+\begin{verbatim}
+(* File fib.ml *)
+let rec fib n =
+ if n < 2 then 1 else fib (n-1) + fib (n-2);;
+let main () =
+ let arg = int_of_string Sys.argv.(1) in
+ print_int (fib arg);
+ print_newline ();
+ exit 0;;
+main ();;
+\end{verbatim}
+"Sys.argv" is an array of strings containing the command-line
+parameters. "Sys.argv.(1)" is thus the first command-line parameter.
+The program above is compiled and executed with the following shell
+commands:
+\begin{verbatim}
+$ ocamlc -o fib fib.ml
+$ ./fib 10
+89
+$ ./fib 20
+10946
+\end{verbatim}
+
+More complex standalone OCaml programs are typically composed of
+multiple source files, and can link with precompiled libraries.
+Chapters~\ref{c:camlc} and~\ref{c:nativecomp} explain how to use the
+batch compilers "ocamlc" and "ocamlopt". Recompilation of
+multi-file OCaml projects can be automated using third-party
+build systems, such as the
+\href{https://github.com/ocaml/ocamlbuild/}{ocamlbuild}
+compilation manager.
--- /dev/null
+\chapter{Labels and variants} \label{c:labl-examples}
+\pdfchapterfold{-2}{Tutorial: Labels and variants}
+%HEVEA\cutname{lablexamples.html}
+{\it (Chapter written by Jacques Garrigue)}
+
+\bigskip
+
+\noindent This chapter gives an overview of the new features in
+OCaml 3: labels, and polymorphic variants.
+
+\section{Labels}
+\pdfsection{Labels}
+
+If you have a look at modules ending in "Labels" in the standard
+library, you will see that function types have annotations you did not
+have in the functions you defined yourself.
+
+\begin{caml_example}{toplevel}
+ListLabels.map;;
+StringLabels.sub;;
+\end{caml_example}
+
+Such annotations of the form "name:" are called {\em labels}. They are
+meant to document the code, allow more checking, and give more
+flexibility to function application.
+You can give such names to arguments in your programs, by prefixing them
+with a tilde "~".
+
+\begin{caml_example}{toplevel}
+let f ~x ~y = x - y;;
+let x = 3 and y = 2 in f ~x ~y;;
+\end{caml_example}
+
+When you want to use distinct names for the variable and the label
+appearing in the type, you can use a naming label of the form
+"~name:". This also applies when the argument is not a variable.
+
+\begin{caml_example}{toplevel}
+let f ~x:x1 ~y:y1 = x1 - y1;;
+f ~x:3 ~y:2;;
+\end{caml_example}
+
+Labels obey the same rules as other identifiers in OCaml, that is you
+cannot use a reserved keyword (like "in" or "to") as label.
+
+Formal parameters and arguments are matched according to their
+respective labels\footnote{This correspond to the commuting label mode
+of Objective Caml 3.00 through 3.02, with some additional flexibility
+on total applications. The so-called classic mode ("-nolabels"
+options) is now deprecated for normal use.}, the absence of label
+being interpreted as the empty label.
+%
+This allows commuting arguments in applications. One can also
+partially apply a function on any argument, creating a new function of
+the remaining parameters.
+
+\begin{caml_example}{toplevel}
+let f ~x ~y = x - y;;
+f ~y:2 ~x:3;;
+ListLabels.fold_left;;
+ListLabels.fold_left [1;2;3] ~init:0 ~f:( + );;
+ListLabels.fold_left ~init:0;;
+\end{caml_example}
+
+If several arguments of a function bear the same label (or no label),
+they will not commute among themselves, and order matters. But they
+can still commute with other arguments.
+
+\begin{caml_example}{toplevel}
+let hline ~x:x1 ~x:x2 ~y = (x1, x2, y);;
+hline ~x:3 ~y:2 ~x:5;;
+\end{caml_example}
+
+As an exception to the above parameter matching rules, if an
+application is total (omitting all optional arguments), labels may be
+omitted.
+In practice, many applications are total, so that labels can often be
+omitted.
+\begin{caml_example}{toplevel}
+f 3 2;;
+ListLabels.map succ [1;2;3];;
+\end{caml_example}
+But beware that functions like "ListLabels.fold_left" whose result
+type is a type variable will never be considered as totally applied.
+\begin{caml_example}{toplevel}[error]
+ListLabels.fold_left ( + ) 0 [1;2;3];;
+\end{caml_example}
+
+When a function is passed as an argument to a higher-order function,
+labels must match in both types. Neither adding nor removing labels
+are allowed.
+\begin{caml_example}{toplevel}
+let h g = g ~x:3 ~y:2;;
+h f;;
+h ( + ) [@@expect error];;
+\end{caml_example}
+Note that when you don't need an argument, you can still use a wildcard
+pattern, but you must prefix it with the label.
+\begin{caml_example}{toplevel}
+h (fun ~x:_ ~y -> y+1);;
+\end{caml_example}
+
+\subsection{Optional arguments}
+
+An interesting feature of labeled arguments is that they can be made
+optional. For optional parameters, the question mark "?" replaces the
+tilde "~" of non-optional ones, and the label is also prefixed by "?"
+in the function type.
+Default values may be given for such optional parameters.
+
+\begin{caml_example}{toplevel}
+let bump ?(step = 1) x = x + step;;
+bump 2;;
+bump ~step:3 2;;
+\end{caml_example}
+
+A function taking some optional arguments must also take at least one
+non-optional argument. The criterion for deciding whether an optional
+argument has been omitted is the non-labeled application of an
+argument appearing after this optional argument in the function type.
+Note that if that argument is labeled, you will only be able to
+eliminate optional arguments through the special case for total
+applications.
+
+\begin{caml_example}{toplevel}
+let test ?(x = 0) ?(y = 0) () ?(z = 0) () = (x, y, z);;
+test ();;
+test ~x:2 () ~z:3 ();;
+\end{caml_example}
+
+Optional parameters may also commute with non-optional or unlabeled
+ones, as long as they are applied simultaneously. By nature, optional
+arguments do not commute with unlabeled arguments applied
+independently.
+\begin{caml_example}{toplevel}
+test ~y:2 ~x:3 () ();;
+test () () ~z:1 ~y:2 ~x:3;;
+(test () ()) ~z:1 [@@expect error];;
+\end{caml_example}
+Here "(test () ())" is already "(0,0,0)" and cannot be further
+applied.
+
+Optional arguments are actually implemented as option types. If
+you do not give a default value, you have access to their internal
+representation, "type 'a option = None | Some of 'a". You can then
+provide different behaviors when an argument is present or not.
+
+\begin{caml_example}{toplevel}
+let bump ?step x =
+ match step with
+ | None -> x * 2
+ | Some y -> x + y
+;;
+\end{caml_example}
+
+It may also be useful to relay an optional argument from a function
+call to another. This can be done by prefixing the applied argument
+with "?". This question mark disables the wrapping of optional
+argument in an option type.
+
+\begin{caml_example}{toplevel}
+let test2 ?x ?y () = test ?x ?y () ();;
+test2 ?x:None;;
+\end{caml_example}
+
+\subsection{Labels and type inference}
+\label{ss:label-inference}
+
+While they provide an increased comfort for writing function
+applications, labels and optional arguments have the pitfall that they
+cannot be inferred as completely as the rest of the language.
+
+You can see it in the following two examples.
+\begin{caml_example}{toplevel}
+let h' g = g ~y:2 ~x:3;;
+h' f [@@expect error];;
+let bump_it bump x =
+ bump ~step:2 x;;
+bump_it bump 1 [@@expect error];;
+\end{caml_example}
+The first case is simple: "g" is passed "~y" and then "~x", but "f"
+expects "~x" and then "~y". This is correctly handled if we know the
+type of "g" to be "x:int -> y:int -> int" in advance, but otherwise
+this causes the above type clash. The simplest workaround is to apply
+formal parameters in a standard order.
+
+The second example is more subtle: while we intended the argument
+"bump" to be of type "?step:int -> int -> int", it is inferred as
+"step:int -> int -> 'a".
+%
+These two types being incompatible (internally normal and optional
+arguments are different), a type error occurs when applying "bump_it"
+to the real "bump".
+
+We will not try here to explain in detail how type inference works.
+One must just understand that there is not enough information in the
+above program to deduce the correct type of "g" or "bump". That is,
+there is no way to know whether an argument is optional or not, or
+which is the correct order, by looking only at how a function is
+applied. The strategy used by the compiler is to assume that there are
+no optional arguments, and that applications are done in the right
+order.
+
+The right way to solve this problem for optional parameters is to add
+a type annotation to the argument "bump".
+\begin{caml_example}{toplevel}
+let bump_it (bump : ?step:int -> int -> int) x =
+ bump ~step:2 x;;
+bump_it bump 1;;
+\end{caml_example}
+In practice, such problems appear mostly when using objects whose
+methods have optional arguments, so that writing the type of object
+arguments is often a good idea.
+
+Normally the compiler generates a type error if you attempt to pass to
+a function a parameter whose type is different from the expected one.
+However, in the specific case where the expected type is a non-labeled
+function type, and the argument is a function expecting optional
+parameters, the compiler will attempt to transform the argument to
+have it match the expected type, by passing "None" for all optional
+parameters.
+
+\begin{caml_example}{toplevel}
+let twice f (x : int) = f(f x);;
+twice bump 2;;
+\end{caml_example}
+
+This transformation is coherent with the intended semantics,
+including side-effects. That is, if the application of optional
+parameters shall produce side-effects, these are delayed until the
+received function is really applied to an argument.
+
+\subsection{Suggestions for labeling}
+
+Like for names, choosing labels for functions is not an easy task. A
+good labeling is a labeling which
+
+\begin{itemize}
+\item makes programs more readable,
+\item is easy to remember,
+\item when possible, allows useful partial applications.
+\end{itemize}
+
+We explain here the rules we applied when labeling OCaml
+libraries.
+
+To speak in an ``object-oriented'' way, one can consider that each
+function has a main argument, its {\em object}, and other arguments
+related with its action, the {\em parameters}. To permit the
+combination of functions through functionals in commuting label mode, the
+object will not be labeled. Its role is clear from the function
+itself. The parameters are labeled with names reminding of
+their nature or their role. The best labels combine nature and
+role. When this is not possible the role is to be preferred, since the
+nature will
+often be given by the type itself. Obscure abbreviations should be
+avoided.
+\begin{alltt}
+"ListLabels.map : f:('a -> 'b) -> 'a list -> 'b list"
+UnixLabels.write : file_descr -> buf:bytes -> pos:int -> len:int -> unit
+\end{alltt}
+
+When there are several objects of same nature and role, they are all
+left unlabeled.
+\begin{alltt}
+"ListLabels.iter2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> unit"
+\end{alltt}
+
+When there is no preferable object, all arguments are labeled.
+\begin{alltt}
+BytesLabels.blit :
+ src:bytes -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int -> unit
+\end{alltt}
+
+However, when there is only one argument, it is often left unlabeled.
+\begin{alltt}
+BytesLabels.create : int -> bytes
+\end{alltt}
+This principle also applies to functions of several arguments whose
+return type is a type variable, as long as the role of each argument
+is not ambiguous. Labeling such functions may lead to awkward error
+messages when one attempts to omit labels in an application, as we
+have seen with "ListLabels.fold_left".
+
+Here are some of the label names you will find throughout the
+libraries.
+
+\begin{tableau}{|l|l|}{Label}{Meaning}
+\entree{"f:"}{a function to be applied}
+\entree{"pos:"}{a position in a string, array or byte sequence}
+\entree{"len:"}{a length}
+\entree{"buf:"}{a byte sequence or string used as buffer}
+\entree{"src:"}{the source of an operation}
+\entree{"dst:"}{the destination of an operation}
+\entree{"init:"}{the initial value for an iterator}
+\entree{"cmp:"}{a comparison function, {\it e.g.} "Pervasives.compare"}
+\entree{"mode:"}{an operation mode or a flag list}
+\end{tableau}
+
+All these are only suggestions, but keep in mind that the
+choice of labels is essential for readability. Bizarre choices will
+make the program harder to maintain.
+
+In the ideal, the right function name with right labels should be
+enough to understand the function's meaning. Since one can get this
+information with OCamlBrowser or the "ocaml" toplevel, the documentation
+is only used when a more detailed specification is needed.
+
+\begin{caml_eval}
+#label false;;
+\end{caml_eval}
+
+
+\section{Polymorphic variants}
+\pdfsection{Polymorphic variants}
+
+Variants as presented in section~\ref{s:tut-recvariants} are a
+powerful tool to build data structures and algorithms. However they
+sometimes lack flexibility when used in modular programming. This is
+due to the fact that every constructor is assigned to a unique type
+when defined and used. Even if the same name appears in the definition
+of multiple types, the constructor itself belongs to only one type.
+Therefore, one cannot decide that a given constructor belongs to
+multiple types, or consider a value of some type to belong to some
+other type with more constructors.
+
+With polymorphic variants, this original assumption is removed. That
+is, a variant tag does not belong to any type in particular, the type
+system will just check that it is an admissible value according to its
+use. You need not define a type before using a variant tag. A variant
+type will be inferred independently for each of its uses.
+
+\subsection*{Basic use}
+
+In programs, polymorphic variants work like usual ones. You just have
+to prefix their names with a backquote character "`".
+\begin{caml_example}{toplevel}
+[`On; `Off];;
+`Number 1;;
+let f = function `On -> 1 | `Off -> 0 | `Number n -> n;;
+List.map f [`On; `Off];;
+\end{caml_example}
+"[>`Off|`On] list" means that to match this list, you should at
+least be able to match "`Off" and "`On", without argument.
+"[<`On|`Off|`Number of int]" means that "f" may be applied to "`Off",
+"`On" (both without argument), or "`Number" $n$ where
+$n$ is an integer.
+The ">" and "<" inside the variant types show that they may still be
+refined, either by defining more tags or by allowing less. As such, they
+contain an implicit type variable. Because each of the variant types
+appears only once in the whole type, their implicit type variables are
+not shown.
+
+The above variant types were polymorphic, allowing further refinement.
+When writing type annotations, one will most often describe fixed
+variant types, that is types that cannot be refined. This is
+also the case for type abbreviations. Such types do not contain "<" or
+">", but just an enumeration of the tags and their associated types,
+just like in a normal datatype definition.
+\begin{caml_example}{toplevel}
+type 'a vlist = [`Nil | `Cons of 'a * 'a vlist];;
+let rec map f : 'a vlist -> 'b vlist = function
+ | `Nil -> `Nil
+ | `Cons(a, l) -> `Cons(f a, map f l)
+;;
+\end{caml_example}
+
+\subsection*{Advanced use}
+
+Type-checking polymorphic variants is a subtle thing, and some
+expressions may result in more complex type information.
+
+\begin{caml_example}{toplevel}
+let f = function `A -> `C | `B -> `D | x -> x;;
+f `E;;
+\end{caml_example}
+Here we are seeing two phenomena. First, since this matching is open
+(the last case catches any tag), we obtain the type "[> `A | `B]"
+rather than "[< `A | `B]" in a closed matching. Then, since "x" is
+returned as is, input and return types are identical. The notation "as
+'a" denotes such type sharing. If we apply "f" to yet another tag
+"`E", it gets added to the list.
+
+\begin{caml_example}{toplevel}
+let f1 = function `A x -> x = 1 | `B -> true | `C -> false
+let f2 = function `A x -> x = "a" | `B -> true ;;
+let f x = f1 x && f2 x;;
+\end{caml_example}
+Here "f1" and "f2" both accept the variant tags "`A" and "`B", but the
+argument of "`A" is "int" for "f1" and "string" for "f2". In "f"'s
+type "`C", only accepted by "f1", disappears, but both argument types
+appear for "`A" as "int & string". This means that if we
+pass the variant tag "`A" to "f", its argument should be {\em both}
+"int" and "string". Since there is no such value, "f" cannot be
+applied to "`A", and "`B" is the only accepted input.
+
+Even if a value has a fixed variant type, one can still give it a
+larger type through coercions. Coercions are normally written with
+both the source type and the destination type, but in simple cases the
+source type may be omitted.
+\begin{caml_example}{toplevel}
+type 'a wlist = [`Nil | `Cons of 'a * 'a wlist | `Snoc of 'a wlist * 'a];;
+let wlist_of_vlist l = (l : 'a vlist :> 'a wlist);;
+let open_vlist l = (l : 'a vlist :> [> 'a vlist]);;
+fun x -> (x :> [`A|`B|`C]);;
+\end{caml_example}
+
+You may also selectively coerce values through pattern matching.
+\begin{caml_example}{toplevel}
+let split_cases = function
+ | `Nil | `Cons _ as x -> `A x
+ | `Snoc _ as x -> `B x
+;;
+\end{caml_example}
+When an or-pattern composed of variant tags is wrapped inside an
+alias-pattern, the alias is given a type containing only the tags
+enumerated in the or-pattern. This allows for many useful idioms, like
+incremental definition of functions.
+
+\begin{caml_example}{toplevel}
+let num x = `Num x
+let eval1 eval (`Num x) = x
+let rec eval x = eval1 eval x ;;
+let plus x y = `Plus(x,y)
+let eval2 eval = function
+ | `Plus(x,y) -> eval x + eval y
+ | `Num _ as x -> eval1 eval x
+let rec eval x = eval2 eval x ;;
+\end{caml_example}
+
+To make this even more comfortable, you may use type definitions as
+abbreviations for or-patterns. That is, if you have defined "type
+myvariant = [`Tag1 of int | `Tag2 of bool]", then the pattern "#myvariant" is
+equivalent to writing "(`Tag1(_ : int) | `Tag2(_ : bool))".
+\begin{caml_eval}
+type myvariant = [`Tag1 of int | `Tag2 of bool];;
+\end{caml_eval}
+
+Such abbreviations may be used alone,
+\begin{caml_example}{toplevel}
+let f = function
+ | #myvariant -> "myvariant"
+ | `Tag3 -> "Tag3";;
+\end{caml_example}
+or combined with with aliases.
+\begin{caml_example}{toplevel}
+let g1 = function `Tag1 _ -> "Tag1" | `Tag2 _ -> "Tag2";;
+let g = function
+ | #myvariant as x -> g1 x
+ | `Tag3 -> "Tag3";;
+\end{caml_example}
+
+\subsection{Weaknesses of polymorphic variants}
+
+After seeing the power of polymorphic variants, one may wonder why
+they were added to core language variants, rather than replacing them.
+
+The answer is twofold. One first aspect is that while being pretty
+efficient, the lack of static type information allows for less
+optimizations, and makes polymorphic variants slightly heavier than
+core language ones. However noticeable differences would only
+appear on huge data structures.
+
+More important is the fact that polymorphic variants, while being
+type-safe, result in a weaker type discipline. That is, core language
+variants do actually much more than ensuring type-safety, they also
+check that you use only declared constructors, that all constructors
+present in a data-structure are compatible, and they enforce typing
+constraints to their parameters.
+
+For this reason, you must be more careful about making types explicit
+when you use polymorphic variants. When you write a library, this is
+easy since you can describe exact types in interfaces, but for simple
+programs you are probably better off with core language variants.
+
+Beware also that some idioms make trivial errors very hard to find.
+For instance, the following code is probably wrong but the compiler
+has no way to see it.
+\begin{caml_example}{toplevel}
+type abc = [`A | `B | `C] ;;
+let f = function
+ | `As -> "A"
+ | #abc -> "other" ;;
+let f : abc -> string = f ;;
+\end{caml_example}
+You can avoid such risks by annotating the definition itself.
+\begin{caml_example}{toplevel}[error]
+let f : abc -> string = function
+ | `As -> "A"
+ | #abc -> "other" ;;
+\end{caml_example}
--- /dev/null
+\chapter{The module system} \label{c:moduleexamples}
+\pdfchapterfold{-5}{Tutorial: The module system}
+%HEVEA\cutname{moduleexamples.html}
+
+This chapter introduces the module system of OCaml.
+
+\section{Structures}
+\pdfsection{Structures}
+
+A primary motivation for modules is to package together related
+definitions (such as the definitions of a data type and associated
+operations over that type) and enforce a consistent naming scheme for
+these definitions. This avoids running out of names or accidentally
+confusing names. Such a package is called a {\em structure} and
+is introduced by the "struct"\ldots"end" construct, which contains an
+arbitrary sequence of definitions. The structure is usually given a
+name with the "module" binding. Here is for instance a structure
+packaging together a type of priority queues and their operations:
+\begin{caml_example}{toplevel}
+module PrioQueue =
+ struct
+ type priority = int
+ type 'a queue = Empty | Node of priority * 'a * 'a queue * 'a queue
+ let empty = Empty
+ let rec insert queue prio elt =
+ match queue with
+ Empty -> Node(prio, elt, Empty, Empty)
+ | Node(p, e, left, right) ->
+ if prio <= p
+ then Node(prio, elt, insert right p e, left)
+ else Node(p, e, insert right prio elt, left)
+ exception Queue_is_empty
+ let rec remove_top = function
+ Empty -> raise Queue_is_empty
+ | Node(prio, elt, left, Empty) -> left
+ | Node(prio, elt, Empty, right) -> right
+ | Node(prio, elt, (Node(lprio, lelt, _, _) as left),
+ (Node(rprio, relt, _, _) as right)) ->
+ if lprio <= rprio
+ then Node(lprio, lelt, remove_top left, right)
+ else Node(rprio, relt, left, remove_top right)
+ let extract = function
+ Empty -> raise Queue_is_empty
+ | Node(prio, elt, _, _) as queue -> (prio, elt, remove_top queue)
+ end;;
+\end{caml_example}
+Outside the structure, its components can be referred to using the
+``dot notation'', that is, identifiers qualified by a structure name.
+For instance, "PrioQueue.insert" is the function "insert" defined
+inside the structure "PrioQueue" and "PrioQueue.queue" is the type
+"queue" defined in "PrioQueue".
+\begin{caml_example}{toplevel}
+PrioQueue.insert PrioQueue.empty 1 "hello";;
+\end{caml_example}
+
+Another possibility is to open the module, which brings all
+identifiers defined inside the module in the scope of the current
+structure.
+
+\begin{caml_example}{toplevel}
+ open PrioQueue;;
+ insert empty 1 "hello";;
+\end{caml_example}
+
+Opening a module enables lighter access to its components, at the
+cost of making it harder to identify in which module a identifier
+has been defined. In particular, opened modules can shadow
+identifiers present in the current scope, potentially leading
+to confusing errors:
+
+\begin{caml_example}{toplevel}
+ let empty = []
+ open PrioQueue;;
+ let x = 1 :: empty [@@expect error];;
+\end{caml_example}
+
+
+A partial solution to this conundrum is to open modules locally,
+making the components of the module available only in the
+concerned expression. This can also make the code easier to read
+-- the open statement is closer to where it is used-- and to refactor
+-- the code fragment is more self-contained.
+Two constructions are available for this purpose:
+\begin{caml_example}{toplevel}
+ let open PrioQueue in
+ insert empty 1 "hello";;
+\end{caml_example}
+and
+\begin{caml_example}{toplevel}
+ PrioQueue.(insert empty 1 "hello");;
+\end{caml_example}
+In the second form, when the body of a local open is itself delimited
+by parentheses, braces or bracket, the parentheses of the local open
+can be omitted. For instance,
+\begin{caml_example}{toplevel}
+ PrioQueue.[empty] = PrioQueue.([empty]);;
+ PrioQueue.[|empty|] = PrioQueue.([|empty|]);;
+ PrioQueue.{ contents = empty } = PrioQueue.({ contents = empty });;
+\end{caml_example}
+becomes
+\begin{caml_example}{toplevel}
+ PrioQueue.[insert empty 1 "hello"];;
+\end{caml_example}
+
+It is also possible to copy the components of a module inside
+another module by using an "include" statement. This can be
+particularly useful to extend existing modules. As an illustration,
+we could add functions that returns an optional value rather than
+an exception when the priority queue is empty.
+\begin{caml_example}{toplevel}
+ module PrioQueueOpt =
+ struct
+ include PrioQueue
+
+ let remove_top_opt x =
+ try Some(remove_top x) with Queue_is_empty -> None
+
+ let extract_opt x =
+ try Some(extract x) with Queue_is_empty -> None
+ end;;
+\end{caml_example}
+
+\section{Signatures}
+\pdfsection{Signatures}
+
+Signatures are interfaces for structures. A signature specifies
+which components of a structure are accessible from the outside, and
+with which type. It can be used to hide some components of a structure
+(e.g. local function definitions) or export some components with a
+restricted type. For instance, the signature below specifies the three
+priority queue operations "empty", "insert" and "extract", but not the
+auxiliary function "remove_top". Similarly, it makes the "queue" type
+abstract (by not providing its actual representation as a concrete type).
+\begin{caml_example}{toplevel}
+module type PRIOQUEUE =
+ sig
+ type priority = int (* still concrete *)
+ type 'a queue (* now abstract *)
+ val empty : 'a queue
+ val insert : 'a queue -> int -> 'a -> 'a queue
+ val extract : 'a queue -> int * 'a * 'a queue
+ exception Queue_is_empty
+ end;;
+\end{caml_example}
+Restricting the "PrioQueue" structure by this signature results in
+another view of the "PrioQueue" structure where the "remove_top"
+function is not accessible and the actual representation of priority
+queues is hidden:
+\begin{caml_example}{toplevel}
+module AbstractPrioQueue = (PrioQueue : PRIOQUEUE);;
+AbstractPrioQueue.remove_top [@@expect error];;
+AbstractPrioQueue.insert AbstractPrioQueue.empty 1 "hello";;
+\end{caml_example}
+The restriction can also be performed during the definition of the
+structure, as in
+\begin{verbatim}
+module PrioQueue = (struct ... end : PRIOQUEUE);;
+\end{verbatim}
+An alternate syntax is provided for the above:
+\begin{verbatim}
+module PrioQueue : PRIOQUEUE = struct ... end;;
+\end{verbatim}
+
+Like for modules, it is possible to include a signature to copy
+its components inside the current signature. For instance, we
+can extend the PRIOQUEUE signature with the "extract_opt"
+function:
+
+\begin{caml_example}{toplevel}
+module type PRIOQUEUE_WITH_OPT =
+ sig
+ include PRIOQUEUE
+ val extract_opt : 'a queue -> (int * 'a * 'a queue) option
+ end;;
+\end{caml_example}
+
+
+\section{Functors}
+\pdfsection{Functors}
+
+Functors are ``functions'' from modules to modules. Functors let you create
+parameterized modules and then provide other modules as parameter(s) to get
+a specific implementation. For instance, a "Set" module implementing sets
+as sorted lists could be parameterized to work with any module that provides
+an element type and a comparison function "compare" (such as "OrderedString"):
+
+\begin{caml_example}{toplevel}
+type comparison = Less | Equal | Greater;;
+module type ORDERED_TYPE =
+ sig
+ type t
+ val compare: t -> t -> comparison
+ end;;
+module Set =
+ functor (Elt: ORDERED_TYPE) ->
+ struct
+ type element = Elt.t
+ type set = element list
+ let empty = []
+ let rec add x s =
+ match s with
+ [] -> [x]
+ | hd::tl ->
+ match Elt.compare x hd with
+ Equal -> s (* x is already in s *)
+ | Less -> x :: s (* x is smaller than all elements of s *)
+ | Greater -> hd :: add x tl
+ let rec member x s =
+ match s with
+ [] -> false
+ | hd::tl ->
+ match Elt.compare x hd with
+ Equal -> true (* x belongs to s *)
+ | Less -> false (* x is smaller than all elements of s *)
+ | Greater -> member x tl
+ end;;
+\end{caml_example}
+By applying the "Set" functor to a structure implementing an ordered
+type, we obtain set operations for this type:
+\begin{caml_example}{toplevel}
+module OrderedString =
+ struct
+ type t = string
+ let compare x y = if x = y then Equal else if x < y then Less else Greater
+ end;;
+module StringSet = Set(OrderedString);;
+StringSet.member "bar" (StringSet.add "foo" StringSet.empty);;
+\end{caml_example}
+
+\section{Functors and type abstraction}
+\pdfsection{Functors and type abstraction}
+
+As in the "PrioQueue" example, it would be good style to hide the
+actual implementation of the type "set", so that users of the
+structure will not rely on sets being lists, and we can switch later
+to another, more efficient representation of sets without breaking
+their code. This can be achieved by restricting "Set" by a suitable
+functor signature:
+\begin{caml_example}{toplevel}
+module type SETFUNCTOR =
+ functor (Elt: ORDERED_TYPE) ->
+ sig
+ type element = Elt.t (* concrete *)
+ type set (* abstract *)
+ val empty : set
+ val add : element -> set -> set
+ val member : element -> set -> bool
+ end;;
+module AbstractSet = (Set : SETFUNCTOR);;
+module AbstractStringSet = AbstractSet(OrderedString);;
+AbstractStringSet.add "gee" AbstractStringSet.empty;;
+\end{caml_example}
+
+In an attempt to write the type constraint above more elegantly,
+one may wish to name the signature of the structure
+returned by the functor, then use that signature in the constraint:
+\begin{caml_example}{toplevel}
+module type SET =
+ sig
+ type element
+ type set
+ val empty : set
+ val add : element -> set -> set
+ val member : element -> set -> bool
+ end;;
+module WrongSet = (Set : functor(Elt: ORDERED_TYPE) -> SET);;
+module WrongStringSet = WrongSet(OrderedString);;
+WrongStringSet.add "gee" WrongStringSet.empty [@@expect error];;
+\end{caml_example}
+The problem here is that "SET" specifies the type "element"
+abstractly, so that the type equality between "element" in the result
+of the functor and "t" in its argument is forgotten. Consequently,
+"WrongStringSet.element" is not the same type as "string", and the
+operations of "WrongStringSet" cannot be applied to strings.
+As demonstrated above, it is important that the type "element" in the
+signature "SET" be declared equal to "Elt.t"; unfortunately, this is
+impossible above since "SET" is defined in a context where "Elt" does
+not exist. To overcome this difficulty, OCaml provides a
+"with type" construct over signatures that allows enriching a signature
+with extra type equalities:
+\begin{caml_example}{toplevel}
+module AbstractSet2 =
+ (Set : functor(Elt: ORDERED_TYPE) -> (SET with type element = Elt.t));;
+\end{caml_example}
+
+As in the case of simple structures, an alternate syntax is provided
+for defining functors and restricting their result:
+\begin{verbatim}
+module AbstractSet2(Elt: ORDERED_TYPE) : (SET with type element = Elt.t) =
+ struct ... end;;
+\end{verbatim}
+
+Abstracting a type component in a functor result is a powerful
+technique that provides a high degree of type safety, as we now
+illustrate. Consider an ordering over character strings that is
+different from the standard ordering implemented in the
+"OrderedString" structure. For instance, we compare strings without
+distinguishing upper and lower case.
+\begin{caml_example}{toplevel}
+module NoCaseString =
+ struct
+ type t = string
+ let compare s1 s2 =
+ OrderedString.compare (String.lowercase_ascii s1) (String.lowercase_ascii s2)
+ end;;
+module NoCaseStringSet = AbstractSet(NoCaseString);;
+NoCaseStringSet.add "FOO" AbstractStringSet.empty [@@expect error];;
+\end{caml_example}
+Note that the two types "AbstractStringSet.set" and
+"NoCaseStringSet.set" are not compatible, and values of these
+two types do not match. This is the correct behavior: even though both
+set types contain elements of the same type (strings), they are built
+upon different orderings of that type, and different invariants need
+to be maintained by the operations (being strictly increasing for the
+standard ordering and for the case-insensitive ordering). Applying
+operations from "AbstractStringSet" to values of type
+"NoCaseStringSet.set" could give incorrect results, or build
+lists that violate the invariants of "NoCaseStringSet".
+
+\section{Modules and separate compilation}
+\pdfsection{Modules and separate compilation}
+
+All examples of modules so far have been given in the context of the
+interactive system. However, modules are most useful for large,
+batch-compiled programs. For these programs, it is a practical
+necessity to split the source into several files, called compilation
+units, that can be compiled separately, thus minimizing recompilation
+after changes.
+
+In OCaml, compilation units are special cases of structures
+and signatures, and the relationship between the units can be
+explained easily in terms of the module system. A compilation unit \var{A}
+comprises two files:
+\begin{itemize}
+\item the implementation file \var{A}".ml", which contains a sequence
+of definitions, analogous to the inside of a "struct"\ldots"end"
+construct;
+\item the interface file \var{A}".mli", which contains a sequence of
+specifications, analogous to the inside of a "sig"\ldots"end"
+construct.
+\end{itemize}
+These two files together define a structure named \var{A} as if
+the following definition was entered at top-level:
+\begin{alltt}
+module \var{A}: sig (* \hbox{contents of file} \var{A}.mli *) end
+ = struct (* \hbox{contents of file} \var{A}.ml *) end;;
+\end{alltt}
+The files that define the compilation units can be compiled separately
+using the "ocamlc -c" command (the "-c" option means ``compile only, do
+not try to link''); this produces compiled interface files (with
+extension ".cmi") and compiled object code files (with extension
+".cmo"). When all units have been compiled, their ".cmo" files are
+linked together using the "ocamlc" command. For instance, the following
+commands compile and link a program composed of two compilation units
+"Aux" and "Main":
+\begin{verbatim}
+$ ocamlc -c Aux.mli # produces aux.cmi
+$ ocamlc -c Aux.ml # produces aux.cmo
+$ ocamlc -c Main.mli # produces main.cmi
+$ ocamlc -c Main.ml # produces main.cmo
+$ ocamlc -o theprogram Aux.cmo Main.cmo
+\end{verbatim}
+The program behaves exactly as if the following phrases were entered
+at top-level:
+\begin{alltt}
+module Aux: sig (* \rminalltt{contents of} Aux.mli *) end
+ = struct (* \rminalltt{contents of} Aux.ml *) end;;
+module Main: sig (* \rminalltt{contents of} Main.mli *) end
+ = struct (* \rminalltt{contents of} Main.ml *) end;;
+\end{alltt}
+In particular, "Main" can refer to "Aux": the definitions and
+declarations contained in "Main.ml" and "Main.mli" can refer to
+definition in "Aux.ml", using the "Aux."\var{ident} notation, provided
+these definitions are exported in "Aux.mli".
+
+The order in which the ".cmo" files are given to "ocamlc" during the
+linking phase determines the order in which the module definitions
+occur. Hence, in the example above, "Aux" appears first and "Main" can
+refer to it, but "Aux" cannot refer to "Main".
+
+Note that only top-level structures can be mapped to
+separately-compiled files, but neither functors nor module types.
+However, all module-class objects can appear as components of a
+structure, so the solution is to put the functor or module type
+inside a structure, which can then be mapped to a file.
--- /dev/null
+\chapter{Objects in OCaml}
+\label{c:objectexamples}
+\pdfchapterfold{-15}{Tutorial: Objects in OCaml}
+%HEVEA\cutname{objectexamples.html}
+{\it (Chapter written by J\'er\^ome Vouillon, Didier R\'emy and Jacques Garrigue)}
+
+\bigskip
+
+\noindent This chapter gives an overview of the object-oriented features of
+OCaml.
+
+Note that the relationship between object, class and type in OCaml is
+different than in mainstream object-oriented languages such as Java and
+C++, so you shouldn't assume that similar keywords mean the same thing.
+Object-oriented features are used much less frequently in OCaml than
+in those languages. OCaml has alternatives that are often more appropriate,
+such as modules and functors. Indeed, many OCaml programs do not use objects
+at all.
+
+
+\begin{htmlonly}
+
+\ref{ss:classes-and-objects} Classes and objects \\
+\ref{ss:immediate-objects} Immediate objects \\
+\ref{ss:reference-to-self} Reference to self \\
+\ref{ss:initializers} Initializers \\
+\ref{ss:virtual-methods} Virtual methods \\
+\ref{ss:private-methods} Private methods \\
+\ref{ss:class-interfaces} Class interfaces \\
+\ref{ss:inheritance} Inheritance \\
+\ref{ss:multiple-inheritance} Multiple inheritance \\
+\ref{ss:parameterized-classes} Parameterized classes \\
+\ref{ss:polymorphic-methods} Polymorphic methods \\
+\ref{ss:using-coercions} Using coercions \\
+\ref{ss:functional-objects} Functional objects \\
+\ref{ss:cloning-objects} Cloning objects \\
+\ref{ss:recursive-classes} Recursive classes \\
+\ref{ss:binary-methods} Binary methods \\
+\ref{ss:friends} Friends \\
+
+%%\ref{s:advanced-examples} {\bf Advanced examples}
+%%
+%%\ref{ss:bank-accounts} An extended example of bank accounts \\
+%%\ref{ss:modules-as-classes} Simple modules as classes:
+%% \ref{module:string} Strings
+%% \ref{module:stack} Stacks
+%% \ref{module:hashtbl} Hash tables
+%% \ref{module:set} Sets \\
+%%\ref{ss:subject-observer} The subject/observer pattern \\
+
+\end{htmlonly}
+
+\section{Classes and objects}
+\pdfsection{Classes and objects}
+\label{ss:classes-and-objects}
+
+The class "point" below defines one instance variable "x" and two methods
+"get_x" and "move". The initial value of the instance variable is "0".
+The variable "x" is declared mutable, so the method "move" can change
+its value.
+\begin{caml_example}{toplevel}
+class point =
+ object
+ val mutable x = 0
+ method get_x = x
+ method move d = x <- x + d
+ end;;
+\end{caml_example}
+
+We now create a new point "p", instance of the "point" class.
+\begin{caml_example}{toplevel}
+let p = new point;;
+\end{caml_example}
+Note that the type of "p" is "point". This is an abbreviation
+automatically defined by the class definition above. It stands for the
+object type "<get_x : int; move : int -> unit>", listing the methods
+of class "point" along with their types.
+
+We now invoke some methods of "p":
+\begin{caml_example}{toplevel}
+p#get_x;;
+p#move 3;;
+p#get_x;;
+\end{caml_example}
+
+The evaluation of the body of a class only takes place at object
+creation time. Therefore, in the following example, the instance
+variable "x" is initialized to different values for two different
+objects.
+\begin{caml_example}{toplevel}
+let x0 = ref 0;;
+class point =
+ object
+ val mutable x = incr x0; !x0
+ method get_x = x
+ method move d = x <- x + d
+ end;;
+new point#get_x;;
+new point#get_x;;
+\end{caml_example}
+
+The class "point" can also be abstracted over the initial values of
+the "x" coordinate.
+\begin{caml_example}{toplevel}
+class point = fun x_init ->
+ object
+ val mutable x = x_init
+ method get_x = x
+ method move d = x <- x + d
+ end;;
+\end{caml_example}
+Like in function definitions, the definition above can be
+abbreviated as:
+\begin{caml_example}{toplevel}
+class point x_init =
+ object
+ val mutable x = x_init
+ method get_x = x
+ method move d = x <- x + d
+ end;;
+\end{caml_example}
+An instance of the class "point" is now a function that expects an
+initial parameter to create a point object:
+\begin{caml_example}{toplevel}
+new point;;
+let p = new point 7;;
+\end{caml_example}
+The parameter "x_init" is, of course, visible in the whole body of the
+definition, including methods. For instance, the method "get_offset"
+in the class below returns the position of the object relative to its
+initial position.
+\begin{caml_example}{toplevel}
+class point x_init =
+ object
+ val mutable x = x_init
+ method get_x = x
+ method get_offset = x - x_init
+ method move d = x <- x + d
+ end;;
+\end{caml_example}
+%Instance variables can only be used inside methods. For instance it would
+%not be possible to define
+%\begin{caml_example}{toplevel}
+%class point x_init =
+% object
+% val mutable x = x_init
+% val origin = x
+% method get_offset = x - origin
+% method move d = x <- x + d
+% end;;
+%\end{caml_example}
+Expressions can be evaluated and bound before defining the object body
+of the class. This is useful to enforce invariants. For instance,
+points can be automatically adjusted to the nearest point on a grid,
+as follows:
+\begin{caml_example}{toplevel}
+class adjusted_point x_init =
+ let origin = (x_init / 10) * 10 in
+ object
+ val mutable x = origin
+ method get_x = x
+ method get_offset = x - origin
+ method move d = x <- x + d
+ end;;
+\end{caml_example}
+(One could also raise an exception if the "x_init" coordinate is not
+on the grid.) In fact, the same effect could here be obtained by
+calling the definition of class "point" with the value of the
+"origin".
+\begin{caml_example}{toplevel}
+class adjusted_point x_init = point ((x_init / 10) * 10);;
+\end{caml_example}
+An alternate solution would have been to define the adjustment in
+a special allocation function:
+\begin{caml_example}{toplevel}
+let new_adjusted_point x_init = new point ((x_init / 10) * 10);;
+\end{caml_example}
+However, the former pattern is generally more appropriate, since
+the code for adjustment is part of the definition of the class and will be
+inherited.
+
+This ability provides class constructors as can be found in other
+languages. Several constructors can be defined this way to build objects of
+the same class but with different initialization patterns; an
+alternative is to use initializers, as described below in section
+\ref{ss:initializers}.
+
+\section{Immediate objects}
+\pdfsection{Immediate objects}
+\label{ss:immediate-objects}
+
+There is another, more direct way to create an object: create it
+without going through a class.
+
+The syntax is exactly the same as for class expressions, but the
+result is a single object rather than a class. All the constructs
+described in the rest of this section also apply to immediate objects.
+\begin{caml_example}{toplevel}
+let p =
+ object
+ val mutable x = 0
+ method get_x = x
+ method move d = x <- x + d
+ end;;
+p#get_x;;
+p#move 3;;
+p#get_x;;
+\end{caml_example}
+
+Unlike classes, which cannot be defined inside an expression,
+immediate objects can appear anywhere, using variables from their
+environment.
+\begin{caml_example}{toplevel}
+let minmax x y =
+ if x < y then object method min = x method max = y end
+ else object method min = y method max = x end;;
+\end{caml_example}
+
+Immediate objects have two weaknesses compared to classes: their types
+are not abbreviated, and you cannot inherit from them. But these two
+weaknesses can be advantages in some situations, as we will see
+in sections \ref{ss:reference-to-self} and \ref{ss:parameterized-classes}.
+
+\section{Reference to self}
+\pdfsection{Reference to self}
+\label{ss:reference-to-self}
+
+A method or an initializer can invoke methods on self (that is,
+the current object). For that, self must be explicitly bound, here to
+the variable "s" ("s" could be any identifier, even though we will
+often choose the name "self".)
+\begin{caml_example}{toplevel}
+class printable_point x_init =
+ object (s)
+ val mutable x = x_init
+ method get_x = x
+ method move d = x <- x + d
+ method print = print_int s#get_x
+ end;;
+let p = new printable_point 7;;
+p#print;;
+\end{caml_example}
+Dynamically, the variable "s" is bound at the invocation of a method. In
+particular, when the class "printable_point" is inherited, the variable
+"s" will be correctly bound to the object of the subclass.
+
+A common problem with self is that, as its type may be extended in
+subclasses, you cannot fix it in advance. Here is a simple example.
+\begin{caml_example}{toplevel}
+let ints = ref [];;
+class my_int =
+ object (self)
+ method n = 1
+ method register = ints := self :: !ints
+ end [@@expect error];;
+\end{caml_example}
+You can ignore the first two lines of the error message. What matters
+is the last one: putting self into an external reference would make it
+impossible to extend it through inheritance.
+We will see in section \ref{ss:using-coercions} a workaround to this
+problem.
+Note however that, since immediate objects are not extensible, the
+problem does not occur with them.
+\begin{caml_example}{toplevel}
+let my_int =
+ object (self)
+ method n = 1
+ method register = ints := self :: !ints
+ end;;
+\end{caml_example}
+
+\section{Initializers}
+\pdfsection{Initializers}
+\label{ss:initializers}
+
+Let-bindings within class definitions are evaluated before the object
+is constructed. It is also possible to evaluate an expression
+immediately after the object has been built. Such code is written as
+an anonymous hidden method called an initializer. Therefore, it can
+access self and the instance variables.
+\begin{caml_example}{toplevel}
+class printable_point x_init =
+ let origin = (x_init / 10) * 10 in
+ object (self)
+ val mutable x = origin
+ method get_x = x
+ method move d = x <- x + d
+ method print = print_int self#get_x
+ initializer print_string "new point at "; self#print; print_newline ()
+ end;;
+let p = new printable_point 17;;
+\end{caml_example}
+Initializers cannot be overridden. On the contrary, all initializers are
+evaluated sequentially.
+Initializers are particularly useful to enforce invariants.
+Another example can be seen in section \ref{ss:bank-accounts}.
+
+
+\section{Virtual methods}
+\pdfsection{Virtual methods and variables}
+\label{ss:virtual-methods}
+
+It is possible to declare a method without actually defining it, using
+the keyword "virtual". This method will be provided later in
+subclasses. A class containing virtual methods must be flagged
+"virtual", and cannot be instantiated (that is, no object of this class
+can be created). It still defines type abbreviations (treating virtual methods
+as other methods.)
+\begin{caml_example}{toplevel}
+class virtual abstract_point x_init =
+ object (self)
+ method virtual get_x : int
+ method get_offset = self#get_x - x_init
+ method virtual move : int -> unit
+ end;;
+class point x_init =
+ object
+ inherit abstract_point x_init
+ val mutable x = x_init
+ method get_x = x
+ method move d = x <- x + d
+ end;;
+\end{caml_example}
+
+Instance variables can also be declared as virtual, with the same effect
+as with methods.
+\begin{caml_example}{toplevel}
+class virtual abstract_point2 =
+ object
+ val mutable virtual x : int
+ method move d = x <- x + d
+ end;;
+class point2 x_init =
+ object
+ inherit abstract_point2
+ val mutable x = x_init
+ method get_offset = x - x_init
+ end;;
+\end{caml_example}
+
+\section{Private methods}
+\pdfsection{Private methods}
+\label{ss:private-methods}
+
+Private methods are methods that do not appear in object interfaces.
+They can only be invoked from other methods of the same object.
+\begin{caml_example}{toplevel}
+class restricted_point x_init =
+ object (self)
+ val mutable x = x_init
+ method get_x = x
+ method private move d = x <- x + d
+ method bump = self#move 1
+ end;;
+let p = new restricted_point 0;;
+p#move 10 [@@expect error] ;;
+p#bump;;
+\end{caml_example}
+Note that this is not the same thing as private and protected methods
+in Java or C++, which can be called from other objects of the same
+class. This is a direct consequence of the independence between types
+and classes in OCaml: two unrelated classes may produce
+objects of the same type, and there is no way at the type level to
+ensure that an object comes from a specific class. However a possible
+encoding of friend methods is given in section \ref{ss:friends}.
+
+Private methods are inherited (they are by default visible in subclasses),
+unless they are hidden by signature matching, as described below.
+
+Private methods can be made public in a subclass.
+\begin{caml_example}{toplevel}
+class point_again x =
+ object (self)
+ inherit restricted_point x
+ method virtual move : _
+ end;;
+\end{caml_example}
+The annotation "virtual" here is only used to mention a method without
+providing its definition. Since we didn't add the "private"
+annotation, this makes the method public, keeping the original
+definition.
+
+An alternative definition is
+\begin{caml_example}{toplevel}
+class point_again x =
+ object (self : < move : _; ..> )
+ inherit restricted_point x
+ end;;
+\end{caml_example}
+The constraint on self's type is requiring a public "move" method, and
+this is sufficient to override "private".
+
+One could think that a private method should remain private in a subclass.
+However, since the method is visible in a subclass, it is always possible
+to pick its code and define a method of the same name that runs that
+code, so yet another (heavier) solution would be:
+\begin{caml_example}{toplevel}
+class point_again x =
+ object
+ inherit restricted_point x as super
+ method move = super#move
+ end;;
+\end{caml_example}
+
+Of course, private methods can also be virtual. Then, the keywords must
+appear in this order "method private virtual".
+
+\section{Class interfaces}
+\pdfsection{Class interfaces}
+\label{ss:class-interfaces}
+
+
+%XXX Differentiate class type and class interface ?
+
+Class interfaces are inferred from class definitions. They may also
+be defined directly and used to restrict the type of a class. Like class
+declarations, they also define a new type abbreviation.
+\begin{caml_example}{toplevel}
+class type restricted_point_type =
+ object
+ method get_x : int
+ method bump : unit
+end;;
+fun (x : restricted_point_type) -> x;;
+\end{caml_example}
+In addition to program documentation, class interfaces can be used to
+constrain the type of a class. Both concrete instance variables and concrete
+private methods can be hidden by a class type constraint. Public
+methods and virtual members, however, cannot.
+\begin{caml_example}{toplevel}
+class restricted_point' x = (restricted_point x : restricted_point_type);;
+\end{caml_example}
+Or, equivalently:
+\begin{caml_example}{toplevel}
+class restricted_point' = (restricted_point : int -> restricted_point_type);;
+\end{caml_example}
+The interface of a class can also be specified in a module
+signature, and used to restrict the inferred signature of a module.
+\begin{caml_example}{toplevel}
+module type POINT = sig
+ class restricted_point' : int ->
+ object
+ method get_x : int
+ method bump : unit
+ end
+end;;
+module Point : POINT = struct
+ class restricted_point' = restricted_point
+end;;
+\end{caml_example}
+
+\section{Inheritance}
+\pdfsection{Inheritance}
+\label{ss:inheritance}
+
+We illustrate inheritance by defining a class of colored points that
+inherits from the class of points. This class has all instance
+variables and all methods of class "point", plus a new instance
+variable "c" and a new method "color".
+\begin{caml_example}{toplevel}
+class colored_point x (c : string) =
+ object
+ inherit point x
+ val c = c
+ method color = c
+ end;;
+let p' = new colored_point 5 "red";;
+p'#get_x, p'#color;;
+\end{caml_example}
+A point and a colored point have incompatible types, since a point has
+no method "color". However, the function "get_x" below is a generic
+function applying method "get_x" to any object "p" that has this
+method (and possibly some others, which are represented by an ellipsis
+in the type). Thus, it applies to both points and colored points.
+\begin{caml_example}{toplevel}
+let get_succ_x p = p#get_x + 1;;
+get_succ_x p + get_succ_x p';;
+\end{caml_example}
+Methods need not be declared previously, as shown by the example:
+\begin{caml_example}{toplevel}
+let set_x p = p#set_x;;
+let incr p = set_x p (get_succ_x p);;
+\end{caml_example}
+
+\section{Multiple inheritance}
+\pdfsection{Multiple inheritance}
+\label{ss:multiple-inheritance}
+
+Multiple inheritance is allowed. Only the last definition of a method
+is kept: the redefinition in a subclass of a method that was visible in
+the parent class overrides the definition in the parent class.
+Previous definitions of a method can be reused by binding the related
+ancestor. Below, "super" is bound to the ancestor "printable_point".
+The name "super" is a pseudo value identifier that can only be used to
+invoke a super-class method, as in "super#print".
+\begin{caml_example}{toplevel}
+class printable_colored_point y c =
+ object (self)
+ val c = c
+ method color = c
+ inherit printable_point y as super
+ method! print =
+ print_string "(";
+ super#print;
+ print_string ", ";
+ print_string (self#color);
+ print_string ")"
+ end;;
+let p' = new printable_colored_point 17 "red";;
+p'#print;;
+\end{caml_example}
+A private method that has been hidden in the parent class is no longer
+visible, and is thus not overridden. Since initializers are treated as
+private methods, all initializers along the class hierarchy are evaluated,
+in the order they are introduced.
+
+Note that for clarity's sake, the method "print" is explicitly marked as
+overriding another definition by annotating the "method" keyword with
+an exclamation mark "!". If the method "print" were not overriding the
+"print" method of "printable_point", the compiler would raise an error:
+\begin{caml_example}{toplevel}[error]
+ object
+ method! m = ()
+ end;;
+\end{caml_example}
+
+This explicit overriding annotation also works
+for "val" and "inherit":
+\begin{caml_example}{toplevel}
+class another_printable_colored_point y c c' =
+ object (self)
+ inherit printable_point y
+ inherit! printable_colored_point y c
+ val! c = c'
+ end;;
+\end{caml_example}
+
+\section{Parameterized classes}
+\pdfsection{Parameterized classes}
+\label{ss:parameterized-classes}
+
+Reference cells can be implemented as objects.
+The naive definition fails to typecheck:
+\begin{caml_example}{toplevel}[error]
+class oref x_init =
+ object
+ val mutable x = x_init
+ method get = x
+ method set y = x <- y
+ end;;
+\end{caml_example}
+The reason is that at least one of the methods has a polymorphic type
+(here, the type of the value stored in the reference cell), thus
+either the class should be parametric, or the method type should be
+constrained to a monomorphic type. A monomorphic instance of the class could
+be defined by:
+\begin{caml_example}{toplevel}
+class oref (x_init:int) =
+ object
+ val mutable x = x_init
+ method get = x
+ method set y = x <- y
+ end;;
+\end{caml_example}
+Note that since immediate objects do not define a class type, they have
+no such restriction.
+\begin{caml_example}{toplevel}
+let new_oref x_init =
+ object
+ val mutable x = x_init
+ method get = x
+ method set y = x <- y
+ end;;
+\end{caml_example}
+On the other hand, a class for polymorphic references must explicitly
+list the type parameters in its declaration. Class type parameters are
+listed between "[" and "]". The type parameters must also be
+bound somewhere in the class body by a type constraint.
+\begin{caml_example}{toplevel}
+class ['a] oref x_init =
+ object
+ val mutable x = (x_init : 'a)
+ method get = x
+ method set y = x <- y
+ end;;
+let r = new oref 1 in r#set 2; (r#get);;
+\end{caml_example}
+The type parameter in the declaration may actually be constrained in the
+body of the class definition. In the class type, the actual value of
+the type parameter is displayed in the "constraint" clause.
+\begin{caml_example}{toplevel}
+class ['a] oref_succ (x_init:'a) =
+ object
+ val mutable x = x_init + 1
+ method get = x
+ method set y = x <- y
+ end;;
+\end{caml_example}
+Let us consider a more complex example: define a circle, whose center
+may be any kind of point. We put an additional type
+constraint in method "move", since no free variables must remain
+unaccounted for by the class type parameters.
+\begin{caml_example}{toplevel}
+class ['a] circle (c : 'a) =
+ object
+ val mutable center = c
+ method center = center
+ method set_center c = center <- c
+ method move = (center#move : int -> unit)
+ end;;
+\end{caml_example}
+An alternate definition of "circle", using a "constraint" clause in
+the class definition, is shown below. The type "#point" used below in
+the "constraint" clause is an abbreviation produced by the definition
+of class "point". This abbreviation unifies with the type of any
+object belonging to a subclass of class "point". It actually expands to
+"< get_x : int; move : int -> unit; .. >". This leads to the following
+alternate definition of "circle", which has slightly stronger
+constraints on its argument, as we now expect "center" to have a
+method "get_x".
+\begin{caml_example}{toplevel}
+class ['a] circle (c : 'a) =
+ object
+ constraint 'a = #point
+ val mutable center = c
+ method center = center
+ method set_center c = center <- c
+ method move = center#move
+ end;;
+\end{caml_example}
+The class "colored_circle" is a specialized version of class
+"circle" that requires the type of the center to unify with
+"#colored_point", and adds a method "color". Note that when specializing a
+parameterized class, the instance of type parameter must always be
+explicitly given. It is again written between "[" and "]".
+\begin{caml_example}{toplevel}
+class ['a] colored_circle c =
+ object
+ constraint 'a = #colored_point
+ inherit ['a] circle c
+ method color = center#color
+ end;;
+\end{caml_example}
+
+\section{Polymorphic methods}
+\pdfsection{Polymorphic methods}
+\label{ss:polymorphic-methods}
+
+While parameterized classes may be polymorphic in their contents, they
+are not enough to allow polymorphism of method use.
+
+A classical example is defining an iterator.
+\begin{caml_example}{toplevel}
+List.fold_left;;
+class ['a] intlist (l : int list) =
+ object
+ method empty = (l = [])
+ method fold f (accu : 'a) = List.fold_left f accu l
+ end;;
+\end{caml_example}
+At first look, we seem to have a polymorphic iterator, however this
+does not work in practice.
+\begin{caml_example}{toplevel}
+let l = new intlist [1; 2; 3];;
+l#fold (fun x y -> x+y) 0;;
+l;;
+l#fold (fun s x -> s ^ string_of_int x ^ " ") "" [@@expect error];;
+\end{caml_example}
+Our iterator works, as shows its first use for summation. However,
+since objects themselves are not polymorphic (only their constructors
+are), using the "fold" method fixes its type for this individual object.
+Our next attempt to use it as a string iterator fails.
+
+The problem here is that quantification was wrongly located: it is
+not the class we want to be polymorphic, but the "fold" method.
+This can be achieved by giving an explicitly polymorphic type in the
+method definition.
+\begin{caml_example}{toplevel}
+class intlist (l : int list) =
+ object
+ method empty = (l = [])
+ method fold : 'a. ('a -> int -> 'a) -> 'a -> 'a =
+ fun f accu -> List.fold_left f accu l
+ end;;
+let l = new intlist [1; 2; 3];;
+l#fold (fun x y -> x+y) 0;;
+l#fold (fun s x -> s ^ string_of_int x ^ " ") "";;
+\end{caml_example}
+As you can see in the class type shown by the compiler, while
+polymorphic method types must be fully explicit in class definitions
+(appearing immediately after the method name), quantified type
+variables can be left implicit in class descriptions. Why require types
+to be explicit? The problem is that "(int -> int -> int) -> int ->
+int" would also be a valid type for "fold", and it happens to be
+incompatible with the polymorphic type we gave (automatic
+instantiation only works for toplevel types variables, not for inner
+quantifiers, where it becomes an undecidable problem.) So the compiler
+cannot choose between those two types, and must be helped.
+
+However, the type can be completely omitted in the class definition if
+it is already known, through inheritance or type constraints on self.
+Here is an example of method overriding.
+\begin{caml_example*}{toplevel}
+class intlist_rev l =
+ object
+ inherit intlist l
+ method! fold f accu = List.fold_left f accu (List.rev l)
+ end;;
+\end{caml_example*}
+The following idiom separates description and definition.
+\begin{caml_example*}{toplevel}
+class type ['a] iterator =
+ object method fold : ('b -> 'a -> 'b) -> 'b -> 'b end;;
+class intlist l =
+ object (self : int #iterator)
+ method empty = (l = [])
+ method fold f accu = List.fold_left f accu l
+ end;;
+\end{caml_example*}
+Note here the "(self : int #iterator)" idiom, which ensures that this
+object implements the interface "iterator".
+
+Polymorphic methods are called in exactly the same way as normal
+methods, but you should be aware of some limitations of type
+inference. Namely, a polymorphic method can only be called if its
+type is known at the call site. Otherwise, the method will be assumed
+to be monomorphic, and given an incompatible type.
+\begin{caml_example}{toplevel}
+let sum lst = lst#fold (fun x y -> x+y) 0;;
+sum l [@@expect error];;
+\end{caml_example}
+The workaround is easy: you should put a type constraint on the
+parameter.
+\begin{caml_example}{toplevel}
+let sum (lst : _ #iterator) = lst#fold (fun x y -> x+y) 0;;
+\end{caml_example}
+Of course the constraint may also be an explicit method type.
+Only occurences of quantified variables are required.
+\begin{caml_example}{toplevel}
+let sum lst =
+ (lst : < fold : 'a. ('a -> _ -> 'a) -> 'a -> 'a; .. >)#fold (+) 0;;
+\end{caml_example}
+
+Another use of polymorphic methods is to allow some form of implicit
+subtyping in method arguments. We have already seen in section
+\ref{ss:inheritance} how some functions may be polymorphic in the
+class of their argument. This can be extended to methods.
+\begin{caml_example}{toplevel}
+class type point0 = object method get_x : int end;;
+class distance_point x =
+ object
+ inherit point x
+ method distance : 'a. (#point0 as 'a) -> int =
+ fun other -> abs (other#get_x - x)
+ end;;
+let p = new distance_point 3 in
+(p#distance (new point 8), p#distance (new colored_point 1 "blue"));;
+\end{caml_example}
+Note here the special syntax "(#point0 as 'a)" we have to use to
+quantify the extensible part of "#point0". As for the variable binder,
+it can be omitted in class specifications. If you want polymorphism
+inside object field it must be quantified independently.
+\begin{caml_example}{toplevel}
+class multi_poly =
+ object
+ method m1 : 'a. (< n1 : 'b. 'b -> 'b; .. > as 'a) -> _ =
+ fun o -> o#n1 true, o#n1 "hello"
+ method m2 : 'a 'b. (< n2 : 'b -> bool; .. > as 'a) -> 'b -> _ =
+ fun o x -> o#n2 x
+ end;;
+\end{caml_example}
+In method "m1", "o" must be an object with at least a method "n1",
+itself polymorphic. In method "m2", the argument of "n2" and "x" must
+have the same type, which is quantified at the same level as "'a".
+
+\section{Using coercions}
+\pdfsection{Using coercions}
+\label{ss:using-coercions}
+
+Subtyping is never implicit. There are, however, two ways to perform
+subtyping. The most general construction is fully explicit: both the
+domain and the codomain of the type coercion must be given.
+
+We have seen that points and colored points have incompatible types.
+For instance, they cannot be mixed in the same list. However, a
+colored point can be coerced to a point, hiding its "color" method:
+\begin{caml_example}{toplevel}
+let colored_point_to_point cp = (cp : colored_point :> point);;
+let p = new point 3 and q = new colored_point 4 "blue";;
+let l = [p; (colored_point_to_point q)];;
+\end{caml_example}
+An object of type "t" can be seen as an object of type "t'"
+only if "t" is a subtype of "t'". For instance, a point cannot be
+seen as a colored point.
+\begin{caml_example}{toplevel}[error]
+(p : point :> colored_point);;
+\end{caml_example}
+Indeed, narrowing coercions without runtime checks would be unsafe.
+Runtime type checks might raise exceptions, and they would require
+the presence of type information at runtime, which is not the case in
+the OCaml system.
+For these reasons, there is no such operation available in the language.
+
+Be aware that subtyping and inheritance are not related. Inheritance is a
+syntactic relation between classes while subtyping is a semantic relation
+between types. For instance, the class of colored points could have been
+defined directly, without inheriting from the class of points; the type of
+colored points would remain unchanged and thus still be a subtype of
+points.
+% Conversely, the class "int_comparable" inherits from class
+%"comparable", but type "int_comparable" is not a subtype of "comparable".
+%\begin{caml_example}{toplevel}
+%function x -> (x : int_comparable :> comparable);;
+%\end{caml_example}
+
+The domain of a coercion can often be omitted. For instance, one can
+define:
+\begin{caml_example}{toplevel}
+let to_point cp = (cp :> point);;
+\end{caml_example}
+In this case, the function "colored_point_to_point" is an instance of the
+function "to_point". This is not always true, however. The fully
+explicit coercion is more precise and is sometimes unavoidable.
+Consider, for example, the following class:
+\begin{caml_example}{toplevel}
+class c0 = object method m = {< >} method n = 0 end;;
+\end{caml_example}
+The object type "c0" is an abbreviation for "<m : 'a; n : int> as 'a".
+Consider now the type declaration:
+\begin{caml_example}{toplevel}
+class type c1 = object method m : c1 end;;
+\end{caml_example}
+The object type "c1" is an abbreviation for the type "<m : 'a> as 'a".
+The coercion from an object of type "c0" to an object of type "c1" is
+correct:
+\begin{caml_example}{toplevel}
+fun (x:c0) -> (x : c0 :> c1);;
+\end{caml_example}
+%%% FIXME come up with a better example.
+% However, the domain of the coercion cannot be omitted here:
+% \begin{caml_example}{toplevel}
+% fun (x:c0) -> (x :> c1);;
+% \end{caml_example}
+However, the domain of the coercion cannot always be omitted.
+In that case, the solution is to use the explicit form.
+%
+Sometimes, a change in the class-type definition can also solve the problem
+\begin{caml_example}{toplevel}
+class type c2 = object ('a) method m : 'a end;;
+fun (x:c0) -> (x :> c2);;
+\end{caml_example}
+While class types "c1" and "c2" are different, both object types
+"c1" and "c2" expand to the same object type (same method names and types).
+Yet, when the domain of a coercion is left implicit and its co-domain
+is an abbreviation of a known class type, then the class type, rather
+than the object type, is used to derive the coercion function. This
+allows leaving the domain implicit in most cases when coercing form a
+subclass to its superclass.
+%
+The type of a coercion can always be seen as below:
+\begin{caml_example}{toplevel}
+let to_c1 x = (x :> c1);;
+let to_c2 x = (x :> c2);;
+\end{caml_example}
+Note the difference between these two coercions: in the case of "to_c2",
+the type
+"#c2 = < m : 'a; .. > as 'a" is polymorphically recursive (according
+to the explicit recursion in the class type of "c2"); hence the
+success of applying this coercion to an object of class "c0".
+On the other hand, in the first case, "c1" was only expanded and
+unrolled twice to obtain "< m : < m : c1; .. >; .. >" (remember "#c1 =
+< m : c1; .. >"), without introducing recursion.
+You may also note that the type of "to_c2" is "#c2 -> c2" while
+the type of "to_c1" is more general than "#c1 -> c1". This is not always true,
+since there are class types for which some instances of "#c" are not subtypes
+of "c", as explained in section~\ref{ss:binary-methods}. Yet, for
+parameterless classes the coercion "(_ :> c)" is always more general than
+"(_ : #c :> c)".
+%If a class type exposes the type of self through one of its parameters, this
+%is no longer true. Here is a counter-example.
+%\begin{caml_example}{toplevel}
+%class type ['a] c = object ('a) method m : 'a end;;
+%let to_c x = (x :> _ c);;
+%\end{caml_example}
+
+
+A common problem may occur when one tries to define a coercion to a
+class "c" while defining class "c". The problem is due to the type
+abbreviation not being completely defined yet, and so its subtypes are not
+clearly known. Then, a coercion "(_ :> c)" or "(_ : #c :> c)" is taken to be
+the identity function, as in
+\begin{caml_example}{toplevel}
+function x -> (x :> 'a);;
+\end{caml_example}
+As a consequence, if the coercion is applied to "self", as in the
+following example, the type of "self" is unified with the closed type
+"c" (a closed object type is an object type without ellipsis). This
+would constrain the type of self be closed and is thus rejected.
+Indeed, the type of self cannot be closed: this would prevent any
+further extension of the class. Therefore, a type error is generated
+when the unification of this type with another type would result in a
+closed object type.
+\begin{caml_example}{toplevel}[error]
+class c = object method m = 1 end
+and d = object (self)
+ inherit c
+ method n = 2
+ method as_c = (self :> c)
+end;;
+\end{caml_example}
+However, the most common instance of this problem, coercing self to
+its current class, is detected as a special case by the type checker,
+and properly typed.
+\begin{caml_example}{toplevel}
+class c = object (self) method m = (self :> c) end;;
+\end{caml_example}
+This allows the following idiom, keeping a list of all objects
+belonging to a class or its subclasses:
+\begin{caml_example}{toplevel}
+let all_c = ref [];;
+class c (m : int) =
+ object (self)
+ method m = m
+ initializer all_c := (self :> c) :: !all_c
+ end;;
+\end{caml_example}
+This idiom can in turn be used to retrieve an object whose type has
+been weakened:
+\begin{caml_example}{toplevel}
+let rec lookup_obj obj = function [] -> raise Not_found
+ | obj' :: l ->
+ if (obj :> < >) = (obj' :> < >) then obj' else lookup_obj obj l ;;
+let lookup_c obj = lookup_obj obj !all_c;;
+\end{caml_example}
+The type "< m : int >" we see here is just the expansion of "c", due
+to the use of a reference; we have succeeded in getting back an object
+of type "c".
+
+\medskip
+The previous coercion problem can often be avoided by first
+defining the abbreviation, using a class type:
+\begin{caml_example}{toplevel}
+class type c' = object method m : int end;;
+class c : c' = object method m = 1 end
+and d = object (self)
+ inherit c
+ method n = 2
+ method as_c = (self :> c')
+end;;
+\end{caml_example}
+It is also possible to use a virtual class. Inheriting from this class
+simultaneously forces all methods of "c" to have the same
+type as the methods of "c'".
+\begin{caml_example}{toplevel}
+class virtual c' = object method virtual m : int end;;
+class c = object (self) inherit c' method m = 1 end;;
+\end{caml_example}
+One could think of defining the type abbreviation directly:
+\begin{caml_example*}{toplevel}
+type c' = <m : int>;;
+\end{caml_example*}
+However, the abbreviation "#c'" cannot be defined directly in a similar way.
+It can only be defined by a class or a class-type definition.
+This is because a "#"-abbreviation carries an implicit anonymous
+variable ".." that cannot be explicitly named.
+The closer you get to it is:
+\begin{caml_example*}{toplevel}
+type 'a c'_class = 'a constraint 'a = < m : int; .. >;;
+\end{caml_example*}
+with an extra type variable capturing the open object type.
+
+\section{Functional objects}
+\pdfsection{Functional objects}
+\label{ss:functional-objects}
+
+It is possible to write a version of class "point" without assignments
+on the instance variables. The override construct "{< ... >}" returns a copy of
+``self'' (that is, the current object), possibly changing the value of
+some instance variables.
+\begin{caml_example}{toplevel}
+class functional_point y =
+ object
+ val x = y
+ method get_x = x
+ method move d = {< x = x + d >}
+ end;;
+let p = new functional_point 7;;
+p#get_x;;
+(p#move 3)#get_x;;
+p#get_x;;
+\end{caml_example}
+Note that the type abbreviation "functional_point" is recursive, which can
+be seen in the class type of "functional_point": the type of self is "'a"
+and "'a" appears inside the type of the method "move".
+
+The above definition of "functional_point" is not equivalent
+to the following:
+\begin{caml_example}{toplevel}
+class bad_functional_point y =
+ object
+ val x = y
+ method get_x = x
+ method move d = new bad_functional_point (x+d)
+ end;;
+\end{caml_example}
+While objects of either class will behave the same, objects of their
+subclasses will be different. In a subclass of "bad_functional_point",
+the method "move" will
+keep returning an object of the parent class. On the contrary, in a
+subclass of "functional_point", the method "move" will return an
+object of the subclass.
+
+Functional update is often used in conjunction with binary methods
+as illustrated in section \ref{module:string}.
+
+\section{Cloning objects}
+\pdfsection{Cloning objects}
+\label{ss:cloning-objects}
+
+Objects can also be cloned, whether they are functional or imperative.
+The library function "Oo.copy" makes a shallow copy of an object. That is,
+it returns a new object that has the same methods and instance
+variables as its argument. The
+instance variables are copied but their contents are shared.
+Assigning a new value to an instance variable of the copy (using a method
+call) will not affect instance variables of the original, and conversely.
+A deeper assignment (for example if the instance variable is a reference cell)
+will of course affect both the original and the copy.
+
+The type of "Oo.copy" is the following:
+\begin{caml_example}{toplevel}
+Oo.copy;;
+\end{caml_example}
+The keyword "as" in that type binds the type variable "'a" to
+the object type "< .. >". Therefore, "Oo.copy" takes an object with
+any methods (represented by the ellipsis), and returns an object of
+the same type. The type of "Oo.copy" is different from type "< .. > ->
+< .. >" as each ellipsis represents a different set of methods.
+Ellipsis actually behaves as a type variable.
+\begin{caml_example}{toplevel}
+let p = new point 5;;
+let q = Oo.copy p;;
+q#move 7; (p#get_x, q#get_x);;
+\end{caml_example}
+In fact, "Oo.copy p" will behave as "p#copy" assuming that a public
+method "copy" with body "{< >}" has been defined in the class of "p".
+
+Objects can be compared using the generic comparison functions "=" and "<>".
+Two objects are equal if and only if they are physically equal. In
+particular, an object and its copy are not equal.
+\begin{caml_example}{toplevel}
+let q = Oo.copy p;;
+p = q, p = p;;
+\end{caml_example}
+Other generic comparisons such as ("<", "<=", ...) can also be used on
+objects. The
+relation "<" defines an unspecified but strict ordering on objects. The
+ordering relationship between two objects is fixed once for all after the
+two objects have been created and it is not affected by mutation of fields.
+
+Cloning and override have a non empty intersection.
+They are interchangeable when used within an object and without
+overriding any field:
+\begin{caml_example}{toplevel}
+class copy =
+ object
+ method copy = {< >}
+ end;;
+class copy =
+ object (self)
+ method copy = Oo.copy self
+ end;;
+\end{caml_example}
+Only the override can be used to actually override fields, and
+only the "Oo.copy" primitive can be used externally.
+
+Cloning can also be used to provide facilities for saving and
+restoring the state of objects.
+\begin{caml_example}{toplevel}
+class backup =
+ object (self : 'mytype)
+ val mutable copy = None
+ method save = copy <- Some {< copy = None >}
+ method restore = match copy with Some x -> x | None -> self
+ end;;
+\end{caml_example}
+The above definition will only backup one level.
+The backup facility can be added to any class by using multiple inheritance.
+\begin{caml_example}{toplevel}
+class ['a] backup_ref x = object inherit ['a] oref x inherit backup end;;
+let rec get p n = if n = 0 then p # get else get (p # restore) (n-1);;
+let p = new backup_ref 0 in
+p # save; p # set 1; p # save; p # set 2;
+[get p 0; get p 1; get p 2; get p 3; get p 4];;
+\end{caml_example}
+We can define a variant of backup that retains all copies. (We also
+add a method "clear" to manually erase all copies.)
+\begin{caml_example}{toplevel}
+class backup =
+ object (self : 'mytype)
+ val mutable copy = None
+ method save = copy <- Some {< >}
+ method restore = match copy with Some x -> x | None -> self
+ method clear = copy <- None
+ end;;
+\end{caml_example}
+\begin{caml_example}{toplevel}
+class ['a] backup_ref x = object inherit ['a] oref x inherit backup end;;
+let p = new backup_ref 0 in
+p # save; p # set 1; p # save; p # set 2;
+[get p 0; get p 1; get p 2; get p 3; get p 4];;
+\end{caml_example}
+
+
+
+\section{Recursive classes}
+\pdfsection{Recursive classes}
+\label{ss:recursive-classes}
+
+Recursive classes can be used to define objects whose types are
+mutually recursive.
+\begin{caml_example}{toplevel}
+class window =
+ object
+ val mutable top_widget = (None : widget option)
+ method top_widget = top_widget
+ end
+and widget (w : window) =
+ object
+ val window = w
+ method window = window
+ end;;
+\end{caml_example}
+Although their types are mutually recursive, the classes "widget" and
+"window" are themselves independent.
+
+
+\section{Binary methods}
+\pdfsection{Binary methods}
+\label{ss:binary-methods}
+
+A binary method is a method which takes an argument of the same type
+as self. The class "comparable" below is a template for classes with a
+binary method "leq" of type "'a -> bool" where the type variable "'a"
+is bound to the type of self. Therefore, "#comparable" expands to "<
+leq : 'a -> bool; .. > as 'a". We see here that the binder "as" also
+allows writing recursive types.
+\begin{caml_example}{toplevel}
+class virtual comparable =
+ object (_ : 'a)
+ method virtual leq : 'a -> bool
+ end;;
+\end{caml_example}
+We then define a subclass "money" of "comparable". The class "money"
+simply wraps floats as comparable objects. We will extend it below with
+more operations. We have to use a type constraint on the class parameter "x"
+because the primitive "<=" is a polymorphic function in
+OCaml. The "inherit" clause ensures that the type of objects
+of this class is an instance of "#comparable".
+\begin{caml_example}{toplevel}
+class money (x : float) =
+ object
+ inherit comparable
+ val repr = x
+ method value = repr
+ method leq p = repr <= p#value
+ end;;
+\end{caml_example}
+% not explained: mutability can be hidden
+Note that the type "money" is not a subtype of type
+"comparable", as the self type appears in contravariant position
+in the type of method "leq".
+Indeed, an object "m" of class "money" has a method "leq"
+that expects an argument of type "money" since it accesses
+its "value" method. Considering "m" of type "comparable" would allow a
+call to method "leq" on "m" with an argument that does not have a method
+"value", which would be an error.
+
+Similarly, the type "money2" below is not a subtype of type "money".
+\begin{caml_example}{toplevel}
+class money2 x =
+ object
+ inherit money x
+ method times k = {< repr = k *. repr >}
+ end;;
+\end{caml_example}
+It is however possible to define functions that manipulate objects of
+type either "money" or "money2": the function "min"
+will return the minimum of any two objects whose type unifies with
+"#comparable". The type of "min" is not the same as "#comparable ->
+#comparable -> #comparable", as the abbreviation "#comparable" hides a
+type variable (an ellipsis). Each occurrence of this abbreviation
+generates a new variable.
+\begin{caml_example}{toplevel}
+let min (x : #comparable) y =
+ if x#leq y then x else y;;
+\end{caml_example}
+This function can be applied to objects of type "money"
+or "money2".
+\begin{caml_example}{toplevel}
+(min (new money 1.3) (new money 3.1))#value;;
+(min (new money2 5.0) (new money2 3.14))#value;;
+\end{caml_example}
+
+More examples of binary methods can be found in sections
+\ref{module:string} and \ref{module:set}.
+
+Note the use of override for method "times".
+Writing "new money2 (k *. repr)" instead of "{< repr = k *. repr >}"
+would not behave well with inheritance: in a subclass "money3" of "money2"
+the "times" method would return an object of class "money2" but not of class
+"money3" as would be expected.
+
+The class "money" could naturally carry another binary method. Here is a
+direct definition:
+\begin{caml_example}{toplevel}
+class money x =
+ object (self : 'a)
+ val repr = x
+ method value = repr
+ method print = print_float repr
+ method times k = {< repr = k *. x >}
+ method leq (p : 'a) = repr <= p#value
+ method plus (p : 'a) = {< repr = x +. p#value >}
+ end;;
+\end{caml_example}
+
+\section{Friends}
+\pdfsection{Friends}
+\label{ss:friends}
+
+The above class "money" reveals a problem that often occurs with binary
+methods. In order to interact with other objects of the same class, the
+representation of "money" objects must be revealed, using a method such as
+"value". If we remove all binary methods (here "plus" and "leq"),
+the representation can easily be hidden inside objects by removing the method
+"value" as well. However, this is not possible as soon as some binary
+method requires access to the representation of objects of the same
+class (other than self).
+\begin{caml_example}{toplevel}
+class safe_money x =
+ object (self : 'a)
+ val repr = x
+ method print = print_float repr
+ method times k = {< repr = k *. x >}
+ end;;
+\end{caml_example}
+Here, the representation of the object is known only to a particular object.
+To make it available to other objects of the same class, we are forced to
+make it available to the whole world. However we can easily restrict the
+visibility of the representation using the module system.
+\begin{caml_example*}{toplevel}
+module type MONEY =
+ sig
+ type t
+ class c : float ->
+ object ('a)
+ val repr : t
+ method value : t
+ method print : unit
+ method times : float -> 'a
+ method leq : 'a -> bool
+ method plus : 'a -> 'a
+ end
+ end;;
+module Euro : MONEY =
+ struct
+ type t = float
+ class c x =
+ object (self : 'a)
+ val repr = x
+ method value = repr
+ method print = print_float repr
+ method times k = {< repr = k *. x >}
+ method leq (p : 'a) = repr <= p#value
+ method plus (p : 'a) = {< repr = x +. p#value >}
+ end
+ end;;
+\end{caml_example*}
+Another example of friend functions may be found in section
+\ref{module:set}. These examples occur when a group of objects (here
+objects of the same class) and functions should see each others internal
+representation, while their representation should be hidden from the
+outside. The solution is always to define all friends in the same module,
+give access to the representation and use a signature constraint to make the
+representation abstract outside the module.
+
+
+
+% LocalWords: typecheck monomorphic uncaptured Subtyping subtyping leq repr Oo
+% LocalWords: val sig bool Euro struct OCaml Vouillon Didier int ref incr init
+% LocalWords: succ mytype rec
+
--- /dev/null
+
+\chapter{Polymorphism and its limitations}%
+\label{c:polymorphism}
+\pdfchapterfold{0}{Tutorial: Polymorphism limitations}
+%HEVEA\cutname{polymorphism.html}
+
+\bigskip
+
+\noindent This chapter covers more advanced questions related to the
+limitations of polymorphic functions and types. There are some situations
+in OCaml where the type inferred by the type checker may be less generic
+than expected. Such non-genericity can stem either from interactions
+between side-effect and typing or the difficulties of implicit polymorphic
+recursion and higher-rank polymorphism.
+
+This chapter details each of these situations and, if it is possible,
+how to recover genericity.
+
+\section{Weak polymorphism and mutation}
+\subsection{Weakly polymorphic types}
+\label{ss:weaktypes}
+Maybe the most frequent examples of non-genericity derive from the
+interactions between polymorphic types and mutation. A simple example
+appears when typing the following expression
+\begin{caml_example}{toplevel}
+let store = ref None ;;
+\end{caml_example}
+Since the type of "None" is "'a option" and the function "ref" has type
+"'b -> 'b ref", a natural deduction for the type of "store" would be
+"'a option ref". However, the inferred type, "'_weak1 option ref", is
+different. Type variables whose name starts with a "_weak" prefix like
+"'_weak1" are weakly polymorphic type variables, sometimes shortened as
+weak type variables.
+A weak type variable is a placeholder for a single type that is currently
+unknown. Once the specific type "t" behind the placeholder type "'_weak1"
+is known, all occurrences of "'_weak1" will be replaced by "t". For instance,
+we can define another option reference and store an "int" inside:
+\begin{caml_example}{toplevel}
+let another_store = ref None ;;
+another_store := Some 0;
+another_store ;;
+\end{caml_example}
+After storing an "int" inside "another_store", the type of "another_store" has
+been updated from "'_weak2 option ref" to "int option ref".
+This distinction between weakly and generic polymorphic type variable protects
+OCaml programs from unsoundness and runtime errors. To understand from where
+unsoundness might come, consider this simple function which swaps a value "x"
+with the value stored inside a "store" reference, if there is such value:
+\begin{caml_example}{toplevel}
+let swap store x = match !store with
+ | None -> store := Some x; x
+ | Some y -> store := Some x; y;;
+\end{caml_example}
+We can apply this function to our store
+\begin{caml_example}{toplevel}
+let one = swap store 1
+let one_again = swap store 2
+let two = swap store 3;;
+\end{caml_example}
+After these three swaps the stored value is "3". Everything is fine up to
+now. We can then try to swap "3" with a more interesting value, for
+instance a function:
+\begin{caml_example}{toplevel}[error]
+let error = swap store (fun x -> x);;
+\end{caml_example}
+At this point, the type checker rightfully complains that it is not
+possible to swap an integer and a function, and that an "int" should always
+be traded for another "int". Furthermore, the type checker prevents us to
+change manually the type of the value stored by "store":
+\begin{caml_example}{toplevel}[error]
+store := Some (fun x -> x);;
+\end{caml_example}
+Indeed, looking at the type of store, we see that the weak type "'_weak1" has
+been replaced by the type "int"
+\begin{caml_example}{toplevel}
+store;;
+\end{caml_example}
+Therefore, after placing an "int" in "store", we cannot use it to store any
+value other than an "int". More generally, weak types protect the program from
+undue mutation of values with a polymorphic type.
+
+%todo: fix indentation in pdfmanual
+Moreover, weak types cannot appear in the signature of toplevel modules:
+types must be known at compilation time. Otherwise, different compilation
+units could replace the weak type with different and incompatible types.
+For this reason, compiling the following small piece of code
+\begin{verbatim}
+let option_ref = ref None
+\end{verbatim}
+yields a compilation error
+\begin{verbatim}
+Error: The type of this expression, '_weak1 option ref,
+ contains type variables that cannot be generalized
+\end{verbatim}
+To solve this error, it is enough to add an explicit type annotation to
+specify the type at declaration time:
+\begin{verbatim}
+let option_ref: int option ref = ref None
+\end{verbatim}
+This is in any case a good practice for such global mutable variables.
+Otherwise, they will pick out the type of first use. If there is a mistake
+at this point, this can result in confusing type errors when later, correct
+uses are flagged as errors.
+
+\subsection{The value restriction}\label{ss:valuerestriction}
+
+Identifying the exact context in which polymorphic types should be
+replaced by weak types in a modular way is a difficult question. Indeed
+the type system must handle the possibility that functions may hide persistent
+mutable states. For instance, the following function uses an internal reference
+to implement a delayed identity function
+\begin{caml_example}{toplevel}
+let make_fake_id () =
+ let store = ref None in
+ fun x -> swap store x ;;
+let fake_id = make_fake_id();;
+\end{caml_example}
+It would be unsound to apply this "fake_id" function to values with different
+types. The function "fake_id" is therefore rightfully assigned the type
+"'_weak3 -> '_weak3" rather than "'a -> 'a". At the same time, it ought to
+be possible to use a local mutable state without impacting the type of a
+function.
+%todo: add an example?
+
+To circumvent these dual difficulties, the type checker considers that any value
+returned by a function might rely on persistent mutable states behind the scene
+and should be given a weak type. This restriction on the type of mutable
+values and the results of function application is called the value restriction.
+Note that this value restriction is conservative: there are situations where the
+value restriction is too cautious and gives a weak type to a value that could be
+safely generalized to a polymorphic type:
+\begin{caml_example}{toplevel}
+let not_id = (fun x -> x) (fun x -> x);;
+\end{caml_example}
+Quite often, this happens when defining function using higher order function.
+To avoid this problem, a solution is to add an explicit argument to the
+function:
+\begin{caml_example}{toplevel}
+let id_again = fun x -> (fun x -> x) (fun x -> x) x;;
+\end{caml_example}
+With this argument, "id_again" is seen as a function definition by the type
+checker and can therefore be generalized. This kind of manipulation is called
+eta-expansion in lambda calculus and is sometimes referred under this name.
+
+\subsection{The relaxed value restriction}
+
+There is another partial solution to the problem of unnecessary weak type,
+which is implemented directly within the type checker. Briefly, it is possible
+to prove that weak types that only appear as type parameters in covariant
+positions --also called positive positions-- can be safely generalized to
+polymorphic types. For instance, the type "'a list" is covariant in "'a":
+\begin{caml_example}{toplevel}
+ let f () = [];;
+ let empty = f ();;
+\end{caml_example}
+Remark that the type inferred for "empty" is "'a list" and not "'_weak5 list"
+that should have occurred with the value restriction since "f ()" is a
+function application.
+
+The value restriction combined with this generalization for covariant type
+parameters is called the relaxed value restriction.
+
+%question: is here the best place for describing variance?
+\subsection{Variance and value restriction}
+Variance describes how type constructors behave with respect to subtyping.
+Consider for instance a pair of type "x" and "xy" with "x" a subtype of "xy",
+denoted "x :> xy":
+\begin{caml_example}{toplevel}
+ type x = [ `X ];;
+ type xy = [ `X | `Y ];;
+\end{caml_example}
+As "x" is a subtype of "xy", we can convert a value of type "x"
+to a value of type "xy":
+\begin{caml_example}{toplevel}
+ let x:x = `X;;
+ let x' = ( x :> xy);;
+\end{caml_example}
+Similarly, if we have a value of type "x list", we can convert it to a value
+of type "xy list", since we could convert each element one by one:
+\begin{caml_example}{toplevel}
+ let l:x list = [`X; `X];;
+ let l' = ( l :> xy list);;
+\end{caml_example}
+In other words, "x :> xy" implies that "x list :> xy list", therefore
+the type constructor "'a list" is covariant (it preserves subtyping)
+in its parameter "'a".
+
+Contrarily, if we have a function that can handle values of type "xy"
+\begin{caml_example}{toplevel}
+ let f: xy -> unit = function
+ | `X -> ()
+ | `Y -> ();;
+\end{caml_example}
+it can also handle values of type "x":
+\begin{caml_example}{toplevel}
+ let f' = (f :> x -> unit);;
+\end{caml_example}
+Note that we can rewrite the type of "f" and "f'" as
+\begin{caml_example}{toplevel}
+ type 'a proc = 'a -> unit
+ let f' = (f: xy proc :> x proc);;
+\end{caml_example}
+In this case, we have "x :> xy" implies "xy proc :> x proc". Notice
+that the second subtyping relation reverse the order of "x" and "xy":
+the type constructor "'a proc" is contravariant in its parameter "'a".
+More generally, the function type constructor "'a -> 'b" is covariant in
+its return type "'b" and contravariant in its argument type "'a".
+
+A type constructor can also be invariant in some of its type parameters,
+neither covariant nor contravariant. A typical example is a reference:
+\begin{caml_example}{toplevel}
+ let x: x ref = ref `X;;
+\end{caml_example}
+If we were able to coerce "x" to the type "xy ref" as a variable "xy",
+we could use "xy" to store the value "`Y" inside the reference and then use
+the "x" value to read this content as a value of type "x",
+which would break the type system.
+
+More generally, as soon as a type variable appears in a position describing
+mutable state it becomes invariant. As a corollary, covariant variables will
+never denote mutable locations and can be safely generalized.
+For a better description, interested readers can consult the original
+article by Jacques Garrigue on
+\url{http://www.math.nagoya-u.ac.jp/~garrigue/papers/morepoly-long.pdf}
+
+Together, the relaxed value restriction and type parameter covariance
+help to avoid eta-expansion in many situations.
+
+\subsection{Abstract data types}
+Moreover, when the type definitions are exposed, the type checker
+is able to infer variance information on its own and one can benefit from
+the relaxed value restriction even unknowingly. However, this is not the case
+anymore when defining new abstract types. As an illustration, we can define a
+module type collection as:
+\begin{caml_example}{toplevel}
+module type COLLECTION = sig
+ type 'a t
+ val empty: unit -> 'a t
+end
+
+module Implementation = struct
+ type 'a t = 'a list
+ let empty ()= []
+end;;
+
+module List2: COLLECTION = Implementation;;
+\end{caml_example}
+
+In this situation, when coercing the module "List2" to the module type
+"COLLECTION", the type checker forgets that "'a List2.t" was covariant
+in "'a". Consequently, the relaxed value restriction does not apply anymore:
+
+\begin{caml_example}{toplevel}
+ List2.empty ();;
+\end{caml_example}
+
+To keep the relaxed value restriction, we need to declare the abstract type
+"'a COLLECTION.t" as covariant in "'a":
+\begin{caml_example}{toplevel}
+module type COLLECTION = sig
+ type +'a t
+ val empty: unit -> 'a t
+end
+
+module List2: COLLECTION = Implementation;;
+\end{caml_example}
+
+We then recover polymorphism:
+
+\begin{caml_example}{toplevel}
+ List2.empty ();;
+\end{caml_example}
+
+\section{Polymorphic recursion}\label{s:polymorphic-recursion}
+
+The second major class of non-genericity is directly related to the problem
+of type inference for polymorphic functions. In some circumstances, the type
+inferred by OCaml might be not general enough to allow the definition of
+some recursive functions, in particular for recursive function acting on
+non-regular algebraic data type.
+
+With a regular polymorphic algebraic data type, the type parameters of
+the type constructor are constant within the definition of the type. For
+instance, we can look at arbitrarily nested list defined as:
+\begin{caml_example}{toplevel}
+ type 'a regular_nested = List of 'a list | Nested of 'a regular_nested list
+ let l = Nested[ List [1]; Nested [List[2;3]]; Nested[Nested[]] ];;
+\end{caml_example}
+Note that the type constructor "regular_nested" always appears as
+"'a regular_nested" in the definition above, with the same parameter
+"'a". Equipped with this type, one can compute a maximal depth with
+a classic recursive function
+\begin{caml_example}{toplevel}
+ let rec maximal_depth = function
+ | List _ -> 1
+ | Nested [] -> 0
+ | Nested (a::q) -> 1 + max (maximal_depth a) (maximal_depth (Nested q));;
+\end{caml_example}
+
+Non-regular recursive algebraic data types correspond to polymorphic algebraic
+data types whose parameter types vary between the left and right side of
+the type definition. For instance, it might be interesting to define a datatype
+that ensures that all lists are nested at the same depth:
+\begin{caml_example}{toplevel}
+ type 'a nested = List of 'a list | Nested of 'a list nested;;
+\end{caml_example}
+Intuitively, a value of type "'a nested" is a list of list \dots of list of
+elements "a" with "k" nested list. We can then adapt the "maximal_depth"
+function defined on "regular_depth" into a "depth" function that computes this
+"k". As a first try, we may define
+\begin{caml_example}{toplevel}[error]
+let rec depth = function
+ | List _ -> 1
+ | Nested n -> 1 + depth n;;
+\end{caml_example}
+The type error here comes from the fact that during the definition of "depth",
+the type checker first assigns to "depth" the type "'a -> 'b ".
+When typing the pattern matching, "'a -> 'b" becomes "'a nested -> 'b", then
+"'a nested -> int" once the "List" branch is typed.
+However, when typing the application "depth n" in the "Nested" branch,
+the type checker encounters a problem: "depth n" is applied to
+"'a list nested", it must therefore have the type
+"'a list nested -> 'b". Unifying this constraint with the previous one
+leads to the impossible constraint "'a list nested = 'a nested".
+In other words, within its definition, the recursive function "depth" is
+applied to values of type "'a t" with different types "'a" due to the
+non-regularity of the type constructor "nested". This creates a problem because
+the type checker had introduced a new type variable "'a" only at the
+\emph{definition} of the function "depth" whereas, here, we need a
+different type variable for every \emph{application} of the function "depth".
+
+\subsection{Explicitly polymorphic annotations}
+The solution of this conundrum is to use an explicitly polymorphic type
+annotation for the type "'a":
+\begin{caml_example}{toplevel}
+let rec depth: 'a. 'a nested -> int = function
+ | List _ -> 1
+ | Nested n -> 1 + depth n;;
+depth ( Nested(List [ [7]; [8] ]) );;
+\end{caml_example}
+In the type of "depth", "'a.'a nested -> int", the type variable "'a"
+is universally quantified. In other words, "'a.'a nested -> int" reads as
+``for all type "'a", "depth" maps "'a nested" values to integers''.
+Whereas the standard type "'a nested -> int" can be interpreted
+as ``let be a type variable "'a", then "depth" maps "'a nested" values
+to integers''. There are two major differences with these two type
+expressions. First, the explicit polymorphic annotation indicates to the
+type checker that it needs to introduce a new type variable every times
+the function "depth" is applied. This solves our problem with the definition
+of the function "depth".
+
+Second, it also notifies the type checker that the type of the function should
+be polymorphic. Indeed, without explicit polymorphic type annotation, the
+following type annotation is perfectly valid
+\begin{caml_example}{toplevel}
+ let sum: 'a -> 'b -> 'c = fun x y -> x + y;;
+\end{caml_example}
+since "'a","'b" and "'c" denote type variables that may or may not be
+polymorphic. Whereas, it is an error to unify an explicitly polymorphic type
+with a non-polymorphic type:
+\begin{caml_example}{toplevel}[error]
+ let sum: 'a 'b 'c. 'a -> 'b -> 'c = fun x y -> x + y;;
+\end{caml_example}
+
+An important remark here is that it is not needed to explicit fully
+the type of "depth": it is sufficient to add annotations only for the
+universally quantified type variables:
+\begin{caml_example}{toplevel}
+let rec depth: 'a. 'a nested -> _ = function
+ | List _ -> 1
+ | Nested n -> 1 + depth n;;
+depth ( Nested(List [ [7]; [8] ]) );;
+\end{caml_example}
+
+%todo: add a paragraph on the interaction with locally abstract type
+
+\subsection{More examples}
+With explicit polymorphic annotations, it becomes possible to implement
+any recursive function that depends only on the structure of the nested
+lists and not on the type of the elements. For instance, a more complex
+example would be to compute the total number of elements of the nested
+lists:
+\begin{caml_example}{toplevel}
+ let len nested =
+ let map_and_sum f = List.fold_left (fun acc x -> acc + f x) 0 in
+ let rec len: 'a. ('a list -> int ) -> 'a nested -> int =
+ fun nested_len n ->
+ match n with
+ | List l -> nested_len l
+ | Nested n -> len (map_and_sum nested_len) n
+ in
+ len List.length nested;;
+len (Nested(Nested(List [ [ [1;2]; [3] ]; [ []; [4]; [5;6;7]]; [[]] ])));;
+\end{caml_example}
+
+Similarly, it may be necessary to use more than one explicitly
+polymorphic type variables, like for computing the nested list of
+list lengths of the nested list:
+\begin{caml_example}{toplevel}
+let shape n =
+ let rec shape: 'a 'b. ('a nested -> int nested) ->
+ ('b list list -> 'a list) -> 'b nested -> int nested
+ = fun nest nested_shape ->
+ function
+ | List l -> raise
+ (Invalid_argument "shape requires nested_list of depth greater than 1")
+ | Nested (List l) -> nest @@ List (nested_shape l)
+ | Nested n ->
+ let nested_shape = List.map nested_shape in
+ let nest x = nest (Nested x) in
+ shape nest nested_shape n in
+ shape (fun n -> n ) (fun l -> List.map List.length l ) n;;
+
+shape (Nested(Nested(List [ [ [1;2]; [3] ]; [ []; [4]; [5;6;7]]; [[]] ])));;
+\end{caml_example}
+
+\section{Higher-rank polymorphic functions}
+
+Explicit polymorphic annotations are however not sufficient to cover all
+the cases where the inferred type of a function is less general than
+expected. A similar problem arises when using polymorphic functions as arguments
+of higher-order functions. For instance, we may want to compute the average
+depth or length of two nested lists:
+\begin{caml_example}{toplevel}
+ let average_depth x y = (depth x + depth y) / 2;;
+ let average_len x y = (len x + len y) / 2;;
+ let one = average_len (List [2]) (List [[]]);;
+\end{caml_example}
+It would be natural to factorize these two definitions as:
+\begin{caml_example}{toplevel}
+ let average f x y = (f x + f y) / 2;;
+\end{caml_example}
+However, the type of "average len" is less generic than the type of
+"average_len", since it requires the type of the first and second argument to
+be the same:
+\begin{caml_example}{toplevel}
+ average_len (List [2]) (List [[]]);;
+ average len (List [2]) (List [[]])[@@expect error];;
+\end{caml_example}
+
+As previously with polymorphic recursion, the problem stems from the fact that
+type variables are introduced only at the start of the "let" definitions. When
+we compute both "f x" and "f y", the type of "x" and "y" are unified together.
+To avoid this unification, we need to indicate to the type checker
+that f is polymorphic in its first argument. In some sense, we would want
+"average" to have type
+\begin{verbatim}
+val average: ('a. 'a nested -> int) -> 'a nested -> 'b nested -> int
+\end{verbatim}
+Note that this syntax is not valid within OCaml: "average" has an universally
+quantified type "'a" inside the type of one of its argument whereas for
+polymorphic recursion the universally quantified type was introduced before
+the rest of the type. This position of the universally quantified type means
+that "average" is a second-rank polymorphic function. This kind of higher-rank
+functions is not directly supported by OCaml: type inference for second-rank
+polymorphic function and beyond is undecidable; therefore using this kind of
+higher-rank functions requires to handle manually these universally quantified
+types.
+
+In OCaml, there are two ways to introduce this kind of explicit universally
+quantified types: universally quantified record fields,
+\begin{caml_example}{toplevel}
+ type 'a nested_reduction = { f:'elt. 'elt nested -> 'a };;
+ let boxed_len = { f = len };;
+\end{caml_example}
+and universally quantified object methods:
+\begin{caml_example}{toplevel}
+ let obj_len = object method f:'a. 'a nested -> 'b = len end;;
+\end{caml_example}
+To solve our problem, we can therefore use either the record solution:
+\begin{caml_example}{toplevel}
+ let average nsm x y = (nsm.f x + nsm.f y) / 2 ;;
+\end{caml_example}
+or the object one:
+\begin{caml_example}{toplevel}
+ let average (obj:<f:'a. 'a nested -> _ > ) x y = (obj#f x + obj#f y) / 2 ;;
+\end{caml_example}
--- /dev/null
+%% An attempt to have several index files
+%%
+%% Defines \altindex{filename}{word to index}
+%% and \makealtindex{filename}
+%%
+%% It is possible to define a macro for each index as follows:
+%% \newcommand{\myindex}{\altindex{myindexfile}}
+%%
+%% This code is not really clean, there are still a number of things
+%% that I don't understand... but it works.
+
+%% \makealtindex{filename} opens filename.idx for writing.
+
+\def\makealtindex#1{\if@filesw
+ \expandafter\newwrite\csname @#1altindexfile\endcsname
+ \immediate\openout\expandafter\csname @#1altindexfile\endcsname=#1.idx
+ \typeout{Writing alternate index file #1.idx}\fi}
+
+%% \@wraltindex makes the assumes that a trailing `\fi' will get bound
+%% to #2. So, it `eats' it as second parameter and reinserts it.
+%% Quick and dirty, I know...
+%% Writes the index entry #3 into #1.
+
+\def\@wraltindex#1#2#3{\let\thepage\relax
+ \xdef\@gtempa{\write#1{\string
+ \indexentry{#3}{\thepage}}}\fi\endgroup\@gtempa
+ \if@nobreak \ifvmode\nobreak\fi\fi\@esphack}
+
+%% \altindex{filename}{index entry} does nothing if
+%% \@<filename>altindexfile is \relax (i.e. filename.idx not open).
+%% Otherwise, writes the index entry, and closes the whole stuff (some
+%% groups, and some \if).
+
+\def\altindex#1{\@bsphack\begingroup
+ \def\protect##1{\string##1\space}\@sanitize
+ \@ifundefined{@#1altindexfile}%
+ {\endgroup\@esphack}%
+ {\@wraltindex{\expandafter\csname @#1altindexfile\endcsname}}
+}
--- /dev/null
+% CAML style option, for use with the caml-latex filter.
+
+\typeout{Document Style option `caml-sl' <7 Apr 92>.}
+\newcommand{\hash}{\#}
+{\catcode`\^^M=\active %
+ \gdef\@camlinputline#1^^M{\normalsize\tt\hash{} #1\par} %
+ \gdef\@camloutputline#1^^M{\small\ttfamily\slshape#1\par} } %
+\def\@camlblankline{\medskip}
+\chardef\@camlbackslash="5C
+\def\@bunderline{\setbox0\hbox\bgroup\let\par\@parinunderline}
+
+\def \@parinunderline {\futurelet \@next \@@parinunderline}
+\def \@@parinunderline {\ifx \@next \? \let \@do \@@par@inunderline \else \let \@do \@@@parinunderline \fi \@do}
+\def \@@par@inunderline #1{\@eunderline\@oldpar\?\@bunderline}
+\def \@@@parinunderline {\@eunderline\@oldpar\@bunderline}
+\def\@eunderline{\egroup\underline{\box0}}
+\def\@camlnoop{}
+
+\def\caml{
+ \bgroup
+ \parindent 0pt
+ \parskip 0pt
+ \let\do\@makeother\dospecials
+ \catcode13=\active % 13 = ^M = CR
+ \catcode92=0 % 92 = \
+ \catcode32=\active % 32 = SPC
+ \frenchspacing
+ \@vobeyspaces
+ \let\@oldpar\par
+ \let\?\@camlinputline
+ \let\:\@camloutputline
+ \let\;\@camlblankline
+ \let\<\@bunderline
+ \let\>\@eunderline
+ \let\\\@camlbackslash
+ \let\-\@camlnoop
+}
+
+\def\endcaml{
+ \egroup
+ \addvspace{\medskipamount}
+}
+
+% Caml-example related command
+\def\camlexample#1{
+ \ifnum\pdfstrcmp{#1}{toplevel}=0
+ \renewcommand{\hash}{\#}
+ \else
+ \renewcommand{\hash}{}
+ \fi
+ \begin{flushleft}
+}
+\def\endcamlexample{\end{flushleft}\renewcommand{\hash}{\#}}
+\def\camlinput{}
+\def\endcamlinput{}
+\def\camloutput{}
+\def\endcamloutput{}
+\def\camlerror{}
+\def\endcamlerror{}
+\def\camlwarn{}
+\def\endcamlwarn{}
--- /dev/null
+% CAML style option, for use with the caml-latex filter.
+
+\typeout{Document Style option `caml' <7 Apr 92>.}
+
+{\catcode`\^^M=\active %
+ \gdef\@camlinputline#1^^M{\tt\##1\par} %
+ \gdef\@camloutputline#1^^M{\tt#1\par} } %
+\def\@camlblankline{\medskip}
+\chardef\@camlbackslash="5C
+
+\def\caml{
+ \bgroup
+ \flushleft
+ \parindent 0pt
+ \parskip 0pt
+ \let\do\@makeother\dospecials
+ \catcode`\^^M=\active
+ \catcode`\\=0
+ \catcode`\ \active
+ \frenchspacing
+ \@vobeyspaces
+ \let\?\@camlinputline
+ \let\:\@camloutputline
+ \let\;\@camlblankline
+ \let\\\@camlbackslash
+}
+
+\def\endcaml{
+ \endflushleft
+ \egroup\noindent
+}
--- /dev/null
+\marginparwidth 0pt \oddsidemargin 0pt \evensidemargin 0pt \marginparsep 0pt
+\topmargin 0pt \textwidth 6.5in \textheight 8.5 in
--- /dev/null
+% LaTeX2HTML Version 0.6.4 : html.sty
+%
+% This file contains definitions of LaTeX commands which are
+% processed in a special way by the translator.
+% For example, there are commands for embedding external hypertext links,
+% for cross-references between documents or for including
+% raw HTML.
+% This file includes the comments.sty file v2.0 by Victor Eijkhout
+% In most cases these commands do nothing when processed by LaTeX.
+
+% Modifications:
+%
+% nd = Nikos Drakos <nikos@cbl.leeds.ac.uk>
+% jz = Jelle van Zeijl <jvzeijl@isou17.estec.esa.nl>
+
+% jz 22-APR-94 - Added support for htmlref
+% nd - Created
+
+
+
+% Exit if the style file is already loaded
+% (suggested by Lee Shombert <las@potomac.wash.inmet.com>
+\ifx \htmlstyloaded\relax \endinput\else\let\htmlstyloaded\relax\fi
+
+%%% LINKS TO EXTERNAL DOCUMENTS
+%
+% This can be used to provide links to arbitrary documents.
+% The first argumment should be the text that is going to be
+% highlighted and the second argument a URL.
+% The hyperlink will appear as a hyperlink in the HTML
+% document and as a footnote in the dvi or ps files.
+%
+\newcommand{\htmladdnormallinkfoot}[2]{ #1\footnote{#2}}
+
+% This is an alternative definition of the command above which
+% will ignore the URL in the dvi or ps files.
+\newcommand{\htmladdnormallink}[2]{ #1 }
+
+% This command takes as argument a URL pointing to an image.
+% The image will be embedded in the HTML document but will
+% be ignored in the dvi and ps files.
+%
+\newcommand{\htmladdimg}[1]{ }
+
+%%% CROSS-REFERENCES BETWEEN (LOCAL OR REMOTE) DOCUMENTS
+%
+% This can be used to refer to symbolic labels in other Latex
+% documents that have already been processed by the translator.
+% The arguments should be:
+% #1 : the URL to the directory containing the external document
+% #2 : the path to the labels.pl file of the external document.
+% If the external document lives on a remote machine then labels.pl
+% must be copied on the local machine.
+%
+%e.g. \externallabels{http://cbl.leeds.ac.uk/nikos/WWW/doc/tex2html/latex2html}
+% {/usr/cblelca/nikos/tmp/labels.pl}
+% The arguments are ignored in the dvi and ps files.
+%
+\newcommand{\externallabels}[2]{ }
+
+% This complements the \externallabels command above. The argument
+% should be a label defined in another latex document and will be
+% ignored in the dvi and ps files.
+%
+\newcommand{\externalref}[1]{ }
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Comment.sty version 2.0, 19 June 1992
+% selectively in/exclude pieces of text: the user can define new
+% comment versions, and each is controlled separately.
+% This style can be used with plain TeX or LaTeX, and probably
+% most other packages too.
+%
+% Examples of use in LaTeX and TeX follow \endinput
+%
+% Author
+% Victor Eijkhout
+% Department of Computer Science
+% University Tennessee at Knoxville
+% 104 Ayres Hall
+% Knoxville, TN 37996
+% USA
+%
+% eijkhout@cs.utk.edu
+%
+% Usage: all text included in between
+% \comment ... \endcomment
+% or \begin{comment} ... \end{comment}
+% is discarded. The closing command should appear on a line
+% of its own. No starting spaces, nothing after it.
+% This environment should work with arbitrary amounts
+% of comment.
+%
+% Other 'comment' environments are defined by
+% and are selected/deselected with
+% \includecomment{versiona}
+% \excludecoment{versionb}
+%
+% These environments are used as
+% \versiona ... \endversiona
+% or \begin{versiona} ... \end{versiona}
+% with the closing command again on a line of its own.
+%
+% Basic approach:
+% to comment something out, scoop up every line in verbatim mode
+% as macro argument, then throw it away.
+% For inclusions, both the opening and closing comands
+% are defined as noop
+%
+% Changed \next to \html@next to prevent clashes with other sty files
+% (mike@emn.fr)
+% Changed \html@next to \htmlnext so the \makeatletter and
+% \makeatother commands could be removed (they were cuasing other
+% style files - changebar.sty - to crash) (nikos@cbl.leeds.ac.uk)
+
+
+\def\makeinnocent#1{\catcode`#1=12 }
+\def\csarg#1#2{\expandafter#1\csname#2\endcsname}
+
+\def\ThrowAwayComment#1{\begingroup
+ \def\CurrentComment{#1}%
+ \let\do\makeinnocent \dospecials
+ \makeinnocent\^^L% and whatever other special cases
+ \endlinechar`\^^M \catcode`\^^M=12 \xComment}
+{\catcode`\^^M=12 \endlinechar=-1 %
+ \gdef\xComment#1^^M{\def\test{#1}
+ \csarg\ifx{PlainEnd\CurrentComment Test}\test
+ \let\htmlnext\endgroup
+ \else \csarg\ifx{LaLaEnd\CurrentComment Test}\test
+ \edef\htmlnext{\endgroup\noexpand\end{\CurrentComment}}
+ \else \let\htmlnext\xComment
+ \fi \fi \htmlnext}
+}
+
+\def\includecomment
+ #1{\expandafter\def\csname#1\endcsname{}%
+ \expandafter\def\csname end#1\endcsname{}}
+\def\excludecomment
+ #1{\expandafter\def\csname#1\endcsname{\ThrowAwayComment{#1}}%
+ {\escapechar=-1\relax
+ \csarg\xdef{PlainEnd#1Test}{\string\\end#1}%
+ \csarg\xdef{LaLaEnd#1Test}{\string\\end\string\{#1\string\}}%
+ }}
+
+\excludecomment{comment}
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%% RAW HTML
+%
+% Enclose raw HTML between a \begin{rawhtml} and \end{rawhtml}.
+% The html environment ignores its body
+%
+\excludecomment{rawhtml}
+
+%%% HTML ONLY
+%
+% Enclose LaTeX constructs which will only appear in the
+% HTML output and will be ignored by LaTeX with
+% \begin{htmlonly} and \end{htmlonly}
+%
+\excludecomment{htmlonly}
+
+%%% LaTeX ONLY
+% Enclose LaTeX constructs which will only appear in the
+% DVI output and will be ignored by latex2html with
+%\begin{latexonly} and \end{latexonly}
+%
+\newenvironment{latexonly}{}{}
+
+%%% HYPERREF
+% Suggested by Eric M. Carol <eric@ca.utoronto.utcc.enfm>
+% Similar to \ref but accepts conditional text.
+% The first argument is HTML text which will become ``hyperized''
+% (underlined).
+% The second and third arguments are text which will appear only in the paper
+% version (DVI file), enclosing the fourth argument which is a reference to a label.
+%
+%e.g. \hyperref{using the tracer}{using the tracer (see Section}{)}{trace}
+% where there is a corresponding \label{trace}
+%
+\newcommand{\hyperref}[4]{#2\ref{#4}#3}
+
+%%% HTMLREF
+% Reference in HTML version only.
+% Mix between \htmladdnormallink and \hyperref.
+% First arg is text for in both versions, second is label for use in HTML
+% version.
+\newcommand{\htmlref}[2]{#1}
+
+%%% HTMLIMAGE
+% This command can be used inside any environment that is converted
+% into an inlined image (eg a "figure" environment) in order to change
+% the way the image will be translated. The argument of \htmlimage
+% is really a string of options separated by commas ie
+% [scale=<scale factor>],[external],[thumbnail=<reduction factor>
+% The scale option allows control over the size of the final image.
+% The ``external'' option will cause the image not to be inlined
+% (images are inlined by default). External images will be accessible
+% via a hypertext link.
+% The ``thumbnail'' option will cause a small inlined image to be
+% placed in the caption. The size of the thumbnail depends on the
+% reduction factor. The use of the ``thumbnail'' option implies
+% the ``external'' option.
+%
+% Example:
+% \htmlimage{scale=1.5,external,thumbnail=0.2}
+% will cause a small thumbnail image 1/5th of the original size to be
+% placed in the final document, pointing to an external image 1.5
+% times bigger than the original.
+%
+\newcommand{\htmlimage}[1]{}
+
+%%% HTMLADDTONAVIGATION
+% This command appends its argument to the buttons in the navigation
+% panel. It is ignored by LaTeX.
+%
+% Example:
+% \htmladdtonavigation{\htmladdnormallink
+% {\htmladdimg{http://server/path/to/gif}}
+% {http://server/path}}
+\newcommand{\htmladdtonavigation}[1]{}
--- /dev/null
+% 1-Jun-1992
+%
+% File bases on iso1ibm.tex Version 1.0 of May, 9 1990
+\message{ISO-latin-1 input coding, version 0.9 of 1-Jun-1992.}
+%
+% For input of 8 bits character.
+% This allows reading ISO-8859 Latin-1 codes.
+%
+\chardef \atcode = \the \catcode `\@
+\catcode `\@ = 11
+%
+\catcode160=13 \def^^a0{{\bf?}} % 160 '240, "a0
+\catcode161=13 \def^^a1{!`} % 161 '241, "a1
+\catcode162=13 \def^^a2{{\bf?}} % 162 '242, "a2
+\catcode163=13 \def^^a3{\pounds{}} % 163 '243, "a3
+\catcode164=13 \def^^a4{{\bf?}} % 164 '244, "a4
+\catcode165=13 \def^^a5{{\bf?}} % 165 '245, "a5
+\catcode166=13 \def^^a6{$\vert$} % 166 '246, "a6
+\catcode167=13 \def^^a7{\S{}} % 167 '247, "a7 \S{} ISO-1,
+\catcode168=13 \def^^a8{\"{ }} % 168 '250, "a8
+\catcode169=13 \def^^a9{\copyright{}}% 169, '251, "a9
+\catcode170=13 \def^^aa{{\bf?}} % 170 '252, "aa
+\catcode171=13 % 171 '253, "ab,
+\@ifundefined{lguill}{\def^^ab{$<<$}}{\def^^ab{\lguill}}
+\catcode172=13 \def^^ac{{\bf?}} % 172 '254, "ac
+\catcode173=13 \def^^ad{{\bf?}} % 173 '255 "ad
+\catcode174=13 \def^^ae{{\bf?}} % 174 '256, "ae
+\catcode175=13 \def^^af{{\bf?}} % 175 '257, "af
+\catcode176=13 \def^^b0{{\bf?}} % 176 '260, "b0 ?? \No
+\catcode177=13 \def^^b1{$\pm$} % 177 '261, "b1 ISO-1 plus-minus
+\catcode178=13 \def^^b2{${}^2$} % 178, '262, "b2
+\catcode179=13 \def^^b3{${}^3$} % 179, '263, "b3
+\catcode180=13 \def^^b4{\'{ }} % 180, '264, "b4
+\catcode181=13 \def^^b5{{\bf?}} % 181, '265, "b5
+\catcode182=13 \def^^b6{\P{}} % 182, '266, "b6
+\catcode183=13 \def^^b7{$\cdot$} % 183, '267, "b7
+\catcode184=13 \def^^b8{\c{ }} % 184, '270, "b8
+\catcode185=13 \def^^b9{${}^1$} % 185, '271, "b9
+\catcode186=13 \def^^ba{{\bf?}} % 186, '272, "ba
+\catcode187=13 % 187, '273, "bb
+\@ifundefined{rguill}{\def^^bb{$>>$}}{\def^^bb{\rguill}}
+\catcode188=13 \def^^bc{$\frac 1 4$} % 188, '274, "bc
+\catcode189=13 \def^^bd{$\frac 1 2$} % 189, '275, "bd
+\catcode190=13 \def^^be{$\frac 3 4$} % 190, '276, "be
+\catcode191=13 \def^^bf{?`} % 191, '277, "bf
+\catcode192=13 \def^^c0{\`A} % 192, '300, "c0
+\@ifundefined{@grave@A@grave@}{\def^^c0{\`A}}{\let^^c0=\@grave@A@grave@}
+\catcode193=13 \def^^c1{\'A} % 193, '301, "c1
+\@ifundefined{@acute@A@acute@}{\def^^c1{\'A}}{\let^^c1=\@acute@A@acute@}
+\catcode194=13 \def^^c2{\^A} % 194, '302, "c2
+\@ifundefined{@circflx@A@circflx@}{\def^^c2{\^A}}{\let^^c2=\@circflx@A@circflx@}
+\catcode195=13 \def^^c3{\~A} % 195, '303, "c3
+\@ifundefined{@tileda@A@tilda@}{\def^^c3{\~A}}{\let^^c3=\@tileda@A@tilda@}
+\catcode196=13 \def^^c4{\"A} % 196, '304, "c4
+\@ifundefined{@Umlaut@A@Umlaut@}{\def^^c4{\"A}}{\let^^c4=\@Umlaut@A@Umlaut@}
+\catcode197=13 \def^^c5{\AA{}} % 197, '305, "c5
+\@ifundefined{@A@A@}{\def^^c5{\AA{}}}{\let^^c5=\@A@A@}
+\catcode198=13 \def^^c6{\AE{}} % 198, '306, "c6
+\@ifundefined{@A@E@}{\def^^c6{\AE{}}}{\let^^c6=\@A@E@}
+\catcode199=13 \def^^c7{\c{C}} % 199, '307, "c7
+\@ifundefined{@cedilla@C@cedilla}{\def^^c7{\c{C}}}{\let^^c7=\@cedilla@C@cedilla}
+\catcode200=13 \def^^c8{\`E} % 200, '310, "c8
+\@ifundefined{@grave@E@grave@}{\def^^c8{\`E}}{\let^^c8=\@grave@E@grave@}
+\catcode201=13 \def^^c9{\'E} % 201, '311, "c9
+\@ifundefined{@acute@E@acute@}{\def^^c9{\'E}}{\let^^c9=\@acute@E@acute@}
+\catcode202=13 \def^^ca{\^E} % 202, '312, "ca
+\@ifundefined{@circflx@E@circflx@}{\def^^ca{\^E}}{\let^^ca=\@circflx@E@circflx@}
+\catcode203=13 \def^^cb{{\"E}} % 203, '313, "cb
+\@ifundefined{@Umlaut@E@Umlaut@}{\def^^cb{\"E}}{\let^^cb=\@Umlaut@E@Umlaut@}
+\catcode204=13 \def^^cc{\`I} % 204, '314, "cc
+\@ifundefined{@grave@I@grave@}{\def^^cc{\`I}}{\let^^cc=\@grave@I@grave@}
+\catcode205=13 \def^^cd{\'I} % 205, '315, "cd
+\@ifundefined{@acute@I@acute@}{\def^^cd{\'I}}{\let^^cd=\@acute@I@acute@}
+\catcode206=13 \def^^ce{\^I} % 206, '316, "ce
+\@ifundefined{@circflx@I@circflx@}{\def^^ce{\^I}}{\let^^ce=\@circflx@I@circflx@}
+\catcode207=13 \def^^cf{{\"I}} % 207, '317, "cf
+\@ifundefined{@Umlaut@I@Umlaut@}{\def^^cf{\"I}}{\let^^cf=\@Umlaut@I@Umlaut@}
+\catcode208=13 \def^^d0{\rlap{\raise0.3ex\hbox{--}}D} % 208, '320, "d0
+\@ifundefined{@Eth@}{}{\let^^d0=\@Eth@}
+\catcode209=13 \def^^d1{¥} % 209, '321, "d1
+\@ifundefined{@tileda@N@tilda@}{\def^^d1{\~N}}{\let^^d1\@tileda@N@tilda@}
+\catcode210=13 \def^^d2{\`O} % 210, '322, "d2
+\@ifundefined{@grave@O@grave@}{\def^^d2{\`O}}{\let^^d2=\@grave@O@grave@}
+\catcode211=13 \def^^d3{\'O} % 211, '323, "d3
+\@ifundefined{@acute@O@acute@}{\def^^d3{\'O}}{\let^^d3\@acute@O@acute@}
+\catcode212=13 \def^^d4{\^O} % 212, '324, "d4
+\@ifundefined{@circflx@O@circflx@}{\def^^d4{\^O}}{\let^^d4=\@circflx@O@circflx@}
+\catcode213=13 \def^^d5{\~O} % 213, '325, "d5
+\@ifundefined{@tileda@O@tilda@}{\def^^d5{\~O}}{\let^^d5\@tileda@O@tilda@}
+\catcode214=13 \def^^d6{\"O} % 214, '326, "d6
+\@ifundefined{@Umlaut@O@Umlaut@}{\def^^d6{\"O}}{\let^^d6=\@Umlaut@O@Umlaut@}
+\catcode215=13 \def^^d7{$\times$}% 215, '327, "d7
+\catcode216=13 \def^^d8{\O{}} % 216, '330, "d8
+\@ifundefined{@OOO@}{\def^^d8{\O{}}}{\let^^d8=\@OOO@}
+\catcode217=13 \def^^d9{\`U} % 217, '331, "d9
+\@ifundefined{@grave@U@grave@}{\def^^d9{\`U}}{\let^^d9=\@grave@U@grave@}
+\catcode218=13 \def^^da{\'U} % 218, '332, "da
+\@ifundefined{@acute@U@acute@}{\def^^da{\'U}}{\let^^da=\@acute@U@acute@}
+\catcode219=13 \def^^db{\^U} % 219, '333, "db
+\@ifundefined{@circflx@U@circflx@}{\def^^db{\^U}}{\let^^db=\@circflx@U@circflx@}
+\catcode220=13 \def^^dc{\"U} % 220, '334, "dc
+\@ifundefined{@Umlaut@U@Umlaut@}{\def^^dc{\"U}}{\let^^dc=\@Umlaut@U@Umlaut@}
+\catcode221=13 \def^^dd{{\'Y}} % 221, '335, "dd
+\@ifundefined{@acute@Y@acute@}{\def^^dd{\'Y}}{\let^^dd=\@acute@Y@acute@}
+\catcode222=13 \def^^de{\lower 0.7ex \hbox{l}\hskip-1ex\relax b} % 222, '336, "de
+\@ifundefined{@Thorn@}{}{\let^^de=\@Thorn@}
+\catcode223=13 \def^^df{\ss{}} % 223, '337, "df
+\@ifundefined{@sss@}{\def^^df{\ss{}}}{\let^^df=\@sss@}
+\catcode224=13 \def^^e0{\`a} % 224, '340, "e0
+\@ifundefined{@grave@a@grave@}{\def^^e0{\`a}}{\let^^e0=\@grave@a@grave@}
+\catcode225=13 \def^^e1{\'a} % 225, '341, "e1
+\@ifundefined{@acute@a@acute@}{\def^^e1{\'a}}{\let^^e1=\@acute@a@acute@}
+\catcode226=13 \def^^e2{\^a} % 226, '342, "e2
+\@ifundefined{@circflx@a@circflx@}{\def^^e2{\^a}}{\let^^e2=\@circflx@a@circflx@}
+\catcode227=13 \def^^e3{\~a} % 227, '343, "e3
+\@ifundefined{@tileda@a@tilda@}{\def^^e3{\~a}}{\let^^e3=\@tileda@a@tilda@}
+\catcode228=13 \def^^e4{\"a} % 228, '344, "e4
+\@ifundefined{@Umlaut@a@Umlaut@}{\def^^e4{\"a}}{\let^^e4=\@Umlaut@a@Umlaut@}
+\catcode229=13 \def^^e5{\aa{}} % 229, '345, "e5
+\@ifundefined{@a@a@}{\def^^e5{\aa{}}}{\let^^e5=\@a@a@}
+\catcode230=13 \def^^e6{\ae{}} % 230, '346, "e6
+\@ifundefined{@a@e@}{\def^^e6{\ae{}}}{\let^^e6=\@a@e@}
+\catcode231=13 \def^^e7{\c{c}} % 231, '347, "e7
+\@ifundefined{@cedilla@c@cedilla}{\def^^e7{\c{c}}}{\let^^e7=\@cedilla@c@cedilla}
+\catcode232=13 \def^^e8{\`e} % 232, '350, "e8
+\@ifundefined{@grave@e@grave@}{\def^^e8{\`e}}{\let^^e8=\@grave@e@grave@}
+\catcode233=13 \def^^e9{\'e} % 233, '351, "e9
+\@ifundefined{@acute@e@acute@}{\def^^e9{\'e}}{\let^^e9=\@acute@e@acute@}
+\catcode234=13 \def^^ea{\^e} % 234, '352, "ea
+\@ifundefined{@circflx@e@circflx@}{\def^^ea{\^e}}{\let^^ea=\@circflx@e@circflx@}
+\catcode235=13 \def^^eb{\"e} % 235, '353, "eb
+\@ifundefined{@Umlaut@e@Umlaut@}{\def^^eb{\"e}}{\let^^eb=\@Umlaut@e@Umlaut@}
+\catcode236=13 \def^^ec{\`{\i}} % 236, '354, "ec
+\@ifundefined{@grave@i@grave@}{\def^^ec{\`{\i}}}{\let^^ec=\@grave@i@grave@}
+\catcode237=13 \def^^ed{\'{\i}} % 237, '355, "ed
+\@ifundefined{@acute@i@acute@}{\def^^ed{\'{\i}}}{\let^^ed=\@acute@i@acute@}
+\catcode238=13 \def^^ee{\^{\i}} % 238, '356, "ee
+\@ifundefined{@circflx@i@circflx@}{\def^^ee{\^{\i}}}{\let^^ee=\@circflx@i@circflx@}
+\catcode239=13 \def^^ef{\"{\i}} % 239, '357, "ef
+\@ifundefined{@Umlaut@i@Umlaut@}{\def^^ef{\"{\i}}}{\let^^ef=\@Umlaut@i@Umlaut@}
+\catcode240=13 \def^^f0{$\partial$} % 240, '360, "f0
+\@ifundefined{@eth@}{\def^^f0{$\partial$}}{\let^^f0=\@eth@}
+\catcode241=13 \def^^f1{\~n} % 241, '361, "f1
+\@ifundefined{@tileda@n@tilda@}{\def^^f1{\~n}}{\let^^f1\@tileda@n@tilda@}
+\catcode242=13 \def^^f2{\`o} % 242, '362, "f2
+\@ifundefined{@grave@o@grave@}{\def^^f2{\`o}}{\let^^f2=\@grave@o@grave@}
+\catcode243=13 \def^^f3{\'o} % 243, '363, "f3
+\@ifundefined{@acute@o@acute@}{\def^^f3{\'o}}{\let^^f3\@acute@o@acute@}
+\catcode244=13 \def^^f4{\^o} % 244, '364, "f4
+\@ifundefined{@circflx@o@circflx@}{\def^^f4{\^o}}{\let^^f4=\@circflx@o@circflx@}
+\catcode245=13 \def^^f5{\~o} % 245, '365, "f5
+\@ifundefined{@tileda@o@tilda@}{\def^^f5{\~o}}{\let^^f5\@tileda@o@tilda@}
+\catcode246=13 \def^^f6{\"o} % 246, '366, "f6
+\@ifundefined{@Umlaut@o@Umlaut@}{\def^^f6{\"o}}{\let^^f6=\@Umlaut@o@Umlaut@}
+\catcode247=13 \def^^f7{$\div$} % 247, '367, "f7
+\catcode248=13 \def^^f8{\o{}} % 248, '370, "f8
+\@ifundefined{@ooo@}{\def^^f8{\o{}}}{\let^^f8=\@ooo@}
+\catcode249=13 \def^^f9{\`u} % 249, '371, "f9
+\@ifundefined{@grave@u@grave@}{\def^^f9{\`u}}{\let^^f9=\@grave@u@grave@}
+\catcode250=13 \def^^fa{\'u} % 250, '372, "fa
+\@ifundefined{@acute@u@acute@}{\def^^fa{\'u}}{\let^^fa=\@acute@u@acute@}
+\catcode251=13 \def^^fb{\^u} % 251, '373, "fb
+\@ifundefined{@circflx@u@circflx@}{\def^^fb{\^u}}{\let^^fb=\@circflx@u@circflx@}
+\catcode252=13 \def^^fc{\"u} % 252, '374, "fc
+\@ifundefined{@Umlaut@u@Umlaut@}{\def^^fc{\"u}}{\let^^fc=\@Umlaut@u@Umlaut@}
+\catcode253=13 \def^^fd{\'y} % 253, '375, "fd
+\@ifundefined{@acute@y@acute@}{\def^^fd{\'y}}{\let^^fd=\@acute@y@acute@}
+\catcode254=13 \def^^fe{\lower 0.8ex\hbox{l}\hskip-1ex\relax b} % 254, '376, "fe
+\@ifundefined{@thorn@}{}{\let^^fe=\@thorn@}
+\catcode255=13 \def^^ff{\"y} % 255, '377, "ff
+\@ifundefined{@Umlaut@y@Umlaut@}{\def^^ff{\"y}}{\let^^ff=\@Umlaut@y@Umlaut@}
+\catcode `\@ = \the \atcode
+\endinput
+% End of iso-latin-1.tex
--- /dev/null
+% Save file as: MULTICOLS.STY Source: FILESERV@SHSU.BITNET
+% multicols.sty version 1.0
+% Allows for multiple column typesetting
+% From TUGboat, voulme 10 (1989), No. 3
+%
+% Frank Mittelback
+% Electronic Data Systems
+% (Deutschland) GmbH
+% Eisenstrasse 56
+% D-6090 Russelsheim
+% Federal Republic of Germany
+% Bitnet: pzf5hz@drueds2
+%
+% Variables:
+% \premulticols - If the space left on the page is less than this, a new
+% page is started before the multiple columns. Otherwise, a \vskip
+% of \multicolsep is added.
+% \postmulticols - analogous to \premulticols
+% \columnseprule - the width of the rule separating the columns.
+%
+% Commands:
+% \raggedcolumns - don't align bottom lines of columns
+% \flushcolumns - align bottom lines (default)
+%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\@ifundefined{mult@cols}{}{\endinput}
+
+\def\multicols#1{\col@number#1\relax
+ \ifnum\col@number<\@ne
+ \@warning{Using '\number\col@number' columns doesn't seem a good idea.^^J
+ I therefore use two columns instead}%
+ \col@number\tw@ \fi
+ \@ifnextchar[\mult@cols{\mult@cols[]}}
+
+\def\mult@cols[#1]{\@ifnextchar[%
+ {\mult@@cols{#1}}%
+ {\mult@@cols{#1}[\premulticols]}}
+
+\def\mult@@cols#1[#2]{%
+ \enough@room#2%
+ #1\par\addvspace\multicolsep
+ \begingroup
+ \prepare@multicols\ignorespaces}
+
+\def\enough@room#1{\par \penalty\z@
+ \page@free \pagegoal
+ \advance \page@free -\pagetotal
+ \ifdim \page@free <#1\newpage \fi}
+
+\def\prepare@multicols{%
+ \output{\global\setbox\partial@page
+ \vbox{\unvbox\@cclv}}\eject
+ \vbadness9999 \hbadness5000
+ \tolerance\multicoltolerance
+ \doublecol@number\col@number
+ \multiply\doublecol@number\tw@
+ \advance\baselineskip\multicolbaselineskip
+ \advance\@colroom-\ht\partial@page
+ \vsize\col@number\@colroom
+ \advance\vsize\c@collectmore\baselineskip
+ \hsize\columnwidth \advance\hsize\columnsep
+ \advance\hsize-\col@number\columnsep
+ \divide\hsize\col@number
+ \linewidth\hsize
+ \output{\multi@columnout}%
+ \multiply\count\footins\col@number
+ \multiply\skip \footins\col@number
+ \reinsert@footnotes}
+
+\def\endmulticols{\par\penalty\z@
+ \output{\balance@columns}\eject
+ \endgroup \reinsert@footnotes
+ \global\c@unbalance\z@
+ \enough@room\postmulticols
+ \addvspace\multicolsep}
+
+\newcount\c@unbalance \c@unbalance = 0
+\newcount\c@collectmore \c@collectmore = 0
+\newcount\col@number
+\newcount\doublecol@number
+\newcount\multicoltolerance \multicoltolerance = 9999
+\newdimen\page@free
+\newdimen\premulticols \premulticols = 50pt
+\newdimen\postmulticols \postmulticols = 20pt
+\newskip\multicolsep \multicolsep = 12pt plus 4pt minus 3pt
+\newskip\multicolbaselineskip \multicolbaselineskip=0pt
+\newbox\partial@page
+
+\def\process@cols#1#2{\count@#1\relax
+ \loop #2%
+ \advance\count@\tw@
+ \ifnum\count@<\doublecol@number
+ \repeat}
+
+\def\page@sofar{\unvbox\partial@page
+ \process@cols\z@{\wd\count@\hsize}%
+ \hbox to\textwidth{%
+ \process@cols\tw@{\box\count@
+ \hss\vrule\@width\columnseprule\hss}%
+ \box\z@}}
+
+\def\reinsert@footnotes{\ifvoid\footins\else
+ \insert\footins{\unvbox\footins}\fi}
+
+\def\multi@columnout{%
+ \ifnum\outputpenalty <-\@Mi
+ \speci@ls \else
+ \splittopskip\topskip
+ \splitmaxdepth\maxdepth
+ \dimen@\@colroom
+ \divide\skip\footins\col@number
+ \ifvoid\footins \else
+ \advance\dimen@-\skip\footins
+ \advance\dimen@-\ht\footins \fi
+ \process@cols\tw@{\setbox\count@
+ \vsplit\@cclv to\dimen@}%
+ \setbox\z@\vsplit\@cclv to\dimen@
+ \ifvoid\@cclv \else
+ \unvbox\@cclv
+ \penalty\outputpenalty
+ \fi
+ \setbox\@cclv\vbox{\page@sofar}%
+ \@makecol\@outputpage
+ \global\@colroom\@colht
+ \process@deferreds
+ \global\vsize\col@number\@colroom
+ \global\advance\vsize
+ \c@collectmore\baselineskip
+ \multiply\skip\footins\col@number\fi}
+
+\def\speci@ls{%
+ \typeout{floats and marginpars not allowed inside `multicols' environment}%
+ \unvbox\@cclv\reinsert@footnotes
+ \gdef\@currlist{}}
+
+\def\process@deferreds{%
+ \@floatplacement
+ \begingroup
+ \let\@tempb\@deferlist
+ \gdef\@deferlist{}%
+ \let\@elt\@scolelt
+ \@tempb \endgroup}
+
+\newif\ifshr@nking
+
+\def\raggedcolumns{%
+ \@bsphack\shr@nkingtrue\@esphack}
+\def\flushcolumns{%
+ \@bsphack\shr@nkingfale\@esphack}
+
+\def\balance@columns{%
+ \splittopskip\topskip
+ \splitmaxdepth\maxdepth
+ \setbox\z@\vbox{\unvbox\@cclv}\dimen@\ht\z@
+ \advance\dimen@\col@number\topskip
+ \advance\dimen@-\col@number\baselineskip
+ \divide\dimen@\col@number
+ \advance\dimen@\c@unbalance\baselineskip
+ {\vbadness\@M \loop
+ {\process@cols\@ne{\global\setbox\count@\box\voidb@x}}%
+ \global\setbox\@ne\copy\z@
+ {\process@cols\thr@@{\global\setbox\count@\vsplit\@ne to\dimen@}}%
+ \ifshr@nking \global\setbox\thr@@\vbox{\unvbox\thr@@}%
+ \fi
+ \ifdim\ht\@ne >\ht\thr@@
+ \global\advance\dimen@\p@
+ \repeat}%
+ \dimen@\ht\thr@@
+ \process@cols\z@{\@tempcnta\count@
+ \advance\@tempcnta\@ne
+ \setbox\count@\vtop to\dimen@
+ {\unvbox\@tempcnta
+ \ifshr@nking\vfill\fi}}%
+ \global\vsize\@colroom
+ \global\advance\vsize\ht\partial@page
+ \page@sofar}
--- /dev/null
+% indexes document style option for producing multiple indexes
+% for use with the modified bbok style, CHbook.sty
+% Written by F.W. Long, Version 1.1, 12 August 1991.
+
+% Modified by F.W. Long, Version 1.1a, 29 August 1991
+% to get the index heading correctly spaced.
+
+% Modified by F.W. Long, Version 1.1b, 31 August 1991
+% to remove the abbreviation \ix (which should be in the document, not here).
+
+% Modified \makeindex and \index commands to allow multiple indexes
+% in both cases the first parameter is the index name.
+% They now work more like \@starttoc and \addcontentsline.
+% \index is no longer defined inside \makeindex but determines
+% whether the appropriate file is defined before writing to it.
+
+\def\makeindex#1{\begingroup
+ \makeatletter
+ \if@filesw \expandafter\newwrite\csname #1@idxfile\endcsname
+ \expandafter\immediate\openout \csname #1@idxfile\endcsname #1.idx\relax
+ \typeout{Writing index file #1.idx }\fi \endgroup}
+
+\def\index#1{\@bsphack\begingroup
+ \def\protect##1{\string##1\space}\@sanitize
+ \@wrindex{#1}}
+
+% \@wrindex now checks that the appropriate file is defined.
+
+\def\@wrindex#1#2{\let\thepage\relax
+ \xdef\@gtempa{\@ifundefined{#1@idxfile}{}{\expandafter
+ \write\csname #1@idxfile\endcsname{\string
+ \indexentry{#2}{\thepage}}}}\endgroup\@gtempa
+ \if@nobreak \ifvmode\nobreak\fi\fi\@esphack}
+
+% Modified \printindex command to allow multiple indexes.
+% This now takes over much of the work of \theindex.
+% Again, the first parameter is the index name.
+% The second parameter is the index title (as printed).
+
+\newif\if@restonecol
+\def\printindex#1#2{\@restonecoltrue\if@twocolumn\@restonecolfalse\fi
+ \columnseprule \z@ \columnsep 35pt
+ \newpage \twocolumn[{\Large\bf #2 \vskip4ex}]
+ \markright{\uppercase{#2}}
+ \addcontentsline{toc}{section}{#2}
+ \@input{#1.ind}}
+
+% The following index commands are taken from book.sty.
+% \theindex is modified to not start a chapter.
+
+\def\theindex{\parindent\z@
+ \parskip\z@ plus .3pt\relax\let\item\@idxitem}
+\def\@idxitem{\par\hangindent 40pt}
+\def\subitem{\par\hangindent 40pt \hspace*{20pt}}
+\def\subsubitem{\par\hangindent 40pt \hspace*{30pt}}
+\def\endtheindex{\if@restonecol\onecolumn\else\clearpage\fi}
+\def\indexspace{\par \vskip 10pt plus 5pt minus 3pt\relax}
+
+% the command \ix allows an abbreviation for the general index
+
+%\def\ix#1{#1\index{general}{#1}}
+
+% define the \see command from makeidx.sty
+
+\def\see#1#2{{\em see\/} #1}
--- /dev/null
+\usepackage{alltt}
+\newenvironment{ocamldoccode}{\begin{alltt}}{\end{alltt}}
+\newenvironment{ocamldocdescription}{\begin{quote}}{\end{quote}}
+\newenvironment{ocamldoccomment}{\begin{quote}}{\end{quote}}
+
+
+\newenvironment{ocamldocindent}{\list{}{}\item\relax}{\endlist}
+\newenvironment{ocamldocsigend}
+ {\noindent\quad\texttt{sig}\ocamldocindent}
+ {\endocamldocindent
+ \noindent\quad\texttt{end}\medskip}
+\newenvironment{ocamldocobjectend}
+ {\noindent\quad\texttt{object}\ocamldocindent}
+ {\endocamldocindent
+ \noindent\quad\texttt{end}\medskip}
+
+\newcommand{\moduleref}[1]{\ifhtml\ahref{libref/#1.html}{\texttt{#1}}\fi}
+
+# For processing .tex generated by ocamldoc (for text manual)
+\newcommand{\ocamldocvspace}[1]{\vspace{#1}}
\ No newline at end of file
--- /dev/null
+
+%% Support macros for LaTeX documentation generated by ocamldoc.
+%% This file is in the public domain; do what you want with it.
+
+\NeedsTeXFormat{LaTeX2e}
+\ProvidesPackage{ocamldoc}
+ [2001/12/04 v1.0 ocamldoc support]
+
+\newenvironment{ocamldoccode}{%
+ \bgroup
+ \leftskip\@totalleftmargin
+ \rightskip\z@skip
+ \parindent\z@
+ \parfillskip\@flushglue
+ \parskip\z@skip
+ %\noindent
+ \@@par\smallskip
+ \@tempswafalse
+ \def\par{%
+ \if@tempswa
+ \leavevmode\null\@@par\penalty\interlinepenalty
+ \else
+ \@tempswatrue
+ \ifhmode\@@par\penalty\interlinepenalty\fi
+ \fi}
+ \obeylines
+ \verbatim@font
+ \let\org@prime~%
+ \@noligs
+ \let\org@dospecials\dospecials
+ \g@remfrom@specials{\\}
+ \g@remfrom@specials{\{}
+ \g@remfrom@specials{\}}
+ \let\do\@makeother
+ \dospecials
+ \let\dospecials\org@dospecials
+ \frenchspacing\@vobeyspaces
+ \everypar \expandafter{\the\everypar \unpenalty}}
+{\egroup\par}
+
+\def\g@remfrom@specials#1{%
+ \def\@new@specials{}
+ \def\@remove##1{%
+ \ifx##1#1\else
+ \g@addto@macro\@new@specials{\do ##1}\fi}
+ \let\do\@remove\dospecials
+ \let\dospecials\@new@specials
+ }
+
+\newenvironment{ocamldocdescription}
+{\list{}{\rightmargin0pt \topsep0pt}\raggedright\item\noindent\relax\ignorespaces}
+{\endlist\medskip}
+
+\newenvironment{ocamldoccomment}
+{\list{}{\leftmargin 2\leftmargini \rightmargin0pt \topsep0pt}\raggedright\item\noindent\relax}
+{\endlist}
+
+\let \ocamldocparagraph \paragraph
+\def \paragraph #1{\ocamldocparagraph {#1}\noindent}
+\let \ocamldocsubparagraph \subparagraph
+\def \subparagraph #1{\ocamldocsubparagraph {#1}\noindent}
+
+\let\ocamldocvspace\vspace
+
+\newenvironment{ocamldocindent}{\list{}{}\item\relax}{\endlist}
+\newenvironment{ocamldocsigend}
+ {\noindent\quad\texttt{sig}\ocamldocindent}
+ {\endocamldocindent\vskip -\lastskip
+ \noindent\quad\texttt{end}\medskip}
+\newenvironment{ocamldocobjectend}
+ {\noindent\quad\texttt{object}\ocamldocindent}
+ {\endocamldocindent\vskip -\lastskip
+ \noindent\quad\texttt{end}\medskip}
+
+\endinput
--- /dev/null
+% Plain text style file.
+
+\typeout{Style option Plaintext}
+
+% Version from John Pavel's dvidoc.sty, March 1987
+% Heavily hacked by Xavier Leroy, June 1993.
+
+% Redefine all fonts to be the "doc" pseudo-font, with fixed spacing.
+% Since rm, tt and mi have different character encodings, we keep
+% several copies of the doc font, with different names, so that dvi2txt
+% can select the right encoding according to the name. Also, we use
+% different names for boldface and italics, so that dvi2txt can select
+% the right style whenever possible.
+
+\def\sl{\rm}
+\def\sc{\rm}
+
+\def\vpt{}
+\def\vipt{}
+\def\viipt{}
+\def\viiipt{}
+\def\ixpt{}
+\def\xipt{}
+\def\xiipt{}
+\def\xivpt{}
+\def\xviipt{}
+\def\xxpt{}
+\def\xxvpt{}
+
+%%% for i in fiv six sev egt nin ten elv twl frtn svnt twty twfv; do
+%%% echo "\\font\\${i}rm = docrm"
+%%% echo "\\font\\${i}mi = docmi"
+%%% echo "\\font\\${i}sy = cmsy10"
+%%% echo "\\font\\${i}it = docit"
+%%% echo "\\font\\${i}bf = docbf"
+%%% echo "\\font\\${i}tt = doctt"
+%%% echo "\\font\\${i}sf = docrm"
+%%% done
+
+\font\fivrm = docrm
+\font\fivmi = docmi
+\font\fivsy = cmsy10
+\font\fivit = docit
+\font\fivbf = docbf
+\font\fivtt = doctt
+\font\fivsf = docrm
+\font\sixrm = docrm
+\font\sixmi = docmi
+\font\sixsy = cmsy10
+\font\sixit = docit
+\font\sixbf = docbf
+\font\sixtt = doctt
+\font\sixsf = docrm
+\font\sevrm = docrm
+\font\sevmi = docmi
+\font\sevsy = cmsy10
+\font\sevit = docit
+\font\sevbf = docbf
+\font\sevtt = doctt
+\font\sevsf = docrm
+\font\egtrm = docrm
+\font\egtmi = docmi
+\font\egtsy = cmsy10
+\font\egtit = docit
+\font\egtbf = docbf
+\font\egttt = doctt
+\font\egtsf = docrm
+\font\ninrm = docrm
+\font\ninmi = docmi
+\font\ninsy = cmsy10
+\font\ninit = docit
+\font\ninbf = docbf
+\font\nintt = doctt
+\font\ninsf = docrm
+\font\tenrm = docrm
+\font\tenmi = docmi
+\font\tensy = cmsy10
+\font\tenit = docit
+\font\tenbf = docbf
+\font\tentt = doctt
+\font\tensf = docrm
+\font\elvrm = docrm
+\font\elvmi = docmi
+\font\elvsy = cmsy10
+\font\elvit = docit
+\font\elvbf = docbf
+\font\elvtt = doctt
+\font\elvsf = docrm
+\font\twlrm = docrm
+\font\twlmi = docmi
+\font\twlsy = cmsy10
+\font\twlit = docit
+\font\twlbf = docbf
+\font\twltt = doctt
+\font\twlsf = docrm
+\font\frtnrm = docrm
+\font\frtnmi = docmi
+\font\frtnsy = cmsy10
+\font\frtnit = docit
+\font\frtnbf = docbf
+\font\frtntt = doctt
+\font\frtnsf = docrm
+\font\svtnrm = docrm
+\font\svtnmi = docmi
+\font\svtnsy = cmsy10
+\font\svtnit = docit
+\font\svtnbf = docbf
+\font\svtntt = doctt
+\font\svtnsf = docrm
+\font\twtyrm = docrm
+\font\twtymi = docmi
+\font\twtysy = cmsy10
+\font\twtyit = docit
+\font\twtybf = docbf
+\font\twtytt = doctt
+\font\twtysf = docrm
+\font\twfvrm = docrm
+\font\twfvmi = docmi
+\font\twfvsy = cmsy10
+\font\twfvit = docit
+\font\twfvbf = docbf
+\font\twfvtt = doctt
+\font\twfvsf = docrm
+
+\rm
+
+% Dimensions
+
+\hsize 78 em % 78 characters per line so fit any screen
+\textwidth 78 em
+\raggedright % Do not try to align on the right
+\parindent=2em % Two blanks for paragraph indentation
+\def\enspace{\kern 1em} \def\enskip{\hskip 1em\relax}
+
+% Vertical skips may best be multiples of \baselineskip
+\baselineskip=12pt % 6 lines per inch
+\normalbaselineskip=\baselineskip
+\vsize 58\baselineskip % 58 lines per page
+\textheight 58\baselineskip
+\voffset=0pt
+\parskip=0pt
+\smallskipamount=0pt
+\medskipamount= \baselineskip
+\bigskipamount=2\baselineskip
+\raggedbottom % do not try to align the page bottom
+
+% By default itemize is done with bullets, which don't look good.
+
+\def\labelitemi{-}
+\def\labelitemii{-}
+\def\labelitemiii{-}
+\def\labelitemiv{-}
+
+% Fix up table of contents. Default latex uses fractional spacing between
+% the section number and title. This comes out as no space in the doc file
+% so we add a space to numberline, and expand tempdima by one em to allow
+% for it. Also, go out of math mode for the dot in the leader. Dots in
+% math mode turn out to be colons!
+%
+\def\@dottedtocline#1#2#3#4#5{\ifnum #1>\c@tocdepth \else
+ \vskip \z@ plus .2pt
+ {\hangindent #2\relax \rightskip \@tocrmarg \parfillskip -\rightskip
+ \parindent #2\relax\@afterindenttrue
+ \interlinepenalty\@M
+ \leavevmode
+ \@tempdima #3\relax
+ \addtolength\@tempdima{1em}
+ #4\nobreak\leaders\hbox to 2em{\hss.\hss}\hfill \nobreak \hbox to\@pnumwidth{\hfil\rm #5}\par}\fi}
+\def\numberline#1{\advance\hangindent\@tempdima \hbox to\@tempdima{#1\hfil}\ }
+%
+% Can't really do superscripts, so do footnotes with []
+%
+\def\@makefnmark{\hbox{(\@thefnmark)}}
+\long\def\@makefntext#1{\parindent 1em\noindent
+ \hbox to 3em{\hss\@thefnmark.}\ #1}
+\skip\footins 24pt plus 4pt minus 2pt
+\def\footnoterule{\kern-12\p@
+\hbox to .4\columnwidth{\leaders\hbox{-}\hfill}}
+%
+% \arrayrulewidth 1em \doublerulesep 1em
+%
+% Some fairly obvious hacks. No odd/even pages in doc files. Can't do the
+% fancy TeX symbols.
+%
+\oddsidemargin 0pt \evensidemargin 0pt
+\def\TeX{TeX}
+\def\LaTeX{LaTeX}
+\def\SliTeX{SliTeX}
+\def\BibTeX{BibTeX}
+%
+% special versions of stuff from xxx10.sty, since only one font size
+%
+\def\@normalsize{\@setsize\normalsize{12pt}\xpt\@xpt
+\abovedisplayskip 12pt
+\belowdisplayskip 12pt
+\abovedisplayshortskip 12pt
+\belowdisplayshortskip 12pt
+\let\@listi\@listI} % Setting of \@listi added 9 Jun 87
+\let\small\@normalsize
+\let\footnotesize\@normalsize
+\normalsize
+\footnotesep 12pt
+\labelsep 10pt
+\def\@listI{\leftmargin\leftmargini \parsep 12pt%
+\topsep 12pt%
+\partopsep 0pt%
+\itemsep 0pt}
+\let\@listi\@listI
+\let\@listii\@listI
+\let\@listiii\@listI
+\let\@listiv\@listI
+\let\@listv\@listI
+\let\@listvi\@listI
+\@listI
+
+% We had sort of random numbers of blank lines around section numbers.
+% Turns out they used various fractional spacing. Rather than depend
+% upon the definition of startsection, just wrap something around it
+% that normalizes the arguments to 12pt. Negative args have special
+% meanings.
+\let\@oldstartsec\@startsection
+\def\@startsection#1#2#3#4#5#6{
+ \@tempskipa #4\relax
+ \@tempskipb #5\relax
+ \ifdim \@tempskipa <\z@ \@tempskipa -12pt \else \@tempskipa 12pt \fi
+ \ifdim \@tempskipb >\z@ \@tempskipb 12pt \fi
+\@oldstartsec{#1}{#2}{#3}{\@tempskipa}{\@tempskipb}{#6}
+}
+
+% To get even spacing in the table of contents
+
+\def\@pnumwidth{3em}
+
+\def\l@part#1#2{\addpenalty{-\@highpenalty}%
+ \addvspace{12pt}% space above part line
+ \begingroup
+ \@tempdima 3em
+ \parindent \z@ \rightskip \@pnumwidth
+ \parfillskip -\@pnumwidth
+ {\large \bf
+ \leavevmode
+ #1\hfil \hbox to\@pnumwidth{\hss #2}}\par
+ \nobreak
+ \global\@nobreaktrue
+ \everypar{\global\@nobreakfalse\everypar{}}%% suggested by
+
+ \endgroup}
+
+\def\l@chapter#1#2{\addpenalty{-\@highpenalty}%
+ \vskip 12pt
+ \@tempdima 2em
+ \begingroup
+ \parindent \z@ \rightskip \@pnumwidth
+ \parfillskip -\@pnumwidth
+ \bf
+ \leavevmode
+ \advance\leftskip\@tempdima
+ \hskip -\leftskip
+ #1\nobreak\hfil \nobreak\hbox to\@pnumwidth{\hss #2}\par
+ \penalty\@highpenalty
+ \endgroup}
+
+\def\l@section{\@dottedtocline{1}{2em}{3em}}
+\def\l@subsection{\@dottedtocline{2}{4em}{3em}}
+\def\l@subsubsection{\@dottedtocline{3}{7em}{4em}}
+\def\l@paragraph{\@dottedtocline{4}{10em}{5em}}
+\def\l@subparagraph{\@dottedtocline{5}{12em}{6em}}
+
--- /dev/null
+% Modification to plaintext.sty to suppress page headings
+% and make pages contiguous when processed with dvi2txt
+
+\pagestyle{empty}
+\advance\voffset by -2\baselineskip
--- /dev/null
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Hevea code for syntax definitions of the ocaml manual %
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Important commands
+% \token, for typesetting grammar terminals
+% \nonterm, for typesetting grammar non-terminals
+%
+% Beware: \nonterm introduces either a local anchor or a local reference
+% -Anchors are introduced when \nonterm occurs in the first column of
+% syntax definitions (environment 'syntax')
+% - References are introduced everywhere else
+%
+% For pure typesetting effect without links (eg. to typeset 'e' as 'expr')
+% use the \nt command (eg. \nt{e}).
+% In syntax definitions, the tool 'transf' translates @word@ into \nt{word}.
+%
+% Warnings are produced
+% - For references to non-defined non terminals
+% - For multiple definitions of the same non-terminal
+% Warnings can be avoided for a given non-terminal 'expr' by issuing
+% the command \stx@silent{'expr'}
+%
+%It is also possible to alias a nonterminal:
+%\stx@alias{name}{othername}
+%will make reference to 'name' point to the definition of non-terminal
+%'othername'
+\newif\ifspace
+\def\addspace{\ifspace\;\spacefalse\fi}
+\ifhtml
+\newcommand{\token}[1]{\texttt{\blue#1}}
+\else
+\newcommand{\token}[1]{\texttt{#1}}
+\fi
+%%% warnings
+\def\stx@warning#1#2{\@ifundefined{stx@#1@silent}{\hva@warn{#2}}{}}
+\def\stx@silent#1{\def\csname stx@#1@silent\endcsname{}}
+%%% Do not warn about those
+%initial example
+\stx@silent{like}\stx@silent{that}%
+%Not defined
+\stx@silent{regular-char}%
+\stx@silent{regular-string-char}%
+%\stx@silent{regular-char-str}%
+\stx@silent{lowercase-ident}%
+\stx@silent{capitalized-ident}%
+\stx@silent{space}%
+\stx@silent{tab}%
+\stx@silent{newline}%
+%Used in many places
+\stx@silent{prefix}%
+\stx@silent{name}%
+\stx@silent{xname}%
+%Not defined
+\stx@silent{external-declaration}%
+\stx@silent{unit-name}%
+%%Redefined in exten.etex
+\stx@silent{parameter}%
+\stx@silent{pattern}%
+\stx@silent{constr-decl}%
+\stx@silent{type-param}%
+\stx@silent{let-binding}%
+\stx@silent{expr}%
+\stx@silent{typexpr}%
+\stx@silent{module-expr}%
+\stx@silent{type-representation}%
+\stx@silent{definition}%
+\stx@silent{specification}%
+\stx@silent{type-equation}%
+\stx@silent{class-field}%
+\stx@silent{mod-constraint}%
+\stx@silent{module-type}%
+\stx@silent{constant}%
+%%Redefined in names.etex
+\stx@silent{label-name}%
+%%Not really defined in lexyacc.etex
+\stx@silent{character-set}%
+\stx@silent{symbol}%
+%%Not defined in debugger.etex
+\stx@silent{integer}
+%%Not defined in ocamldoc.etex
+\stx@silent{string}
+\stx@silent{id}
+\stx@silent{Exc}
+\stx@silent{URL}
+%%%%%%%%%%%%%
+%% Aliases %%
+%%%%%%%%%%%%%
+\newcommand{\stx@alias}[2]{\def\csname stx@#1@alias\endcsname{#2}}
+\stx@alias{typ}{typexpr}%
+\stx@alias{met}{method-name}%
+\stx@alias{tag}{tag-name}%
+\stx@alias{lab}{label-name}%
+\stx@alias{C}{constr-name}
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%special anchor
+\newstyle{a.syntax:link}{color:maroon;text-decoration:underline}
+\newstyle{a.syntax:visited}{color:maroon;text-decoration:underline}
+\newstyle{a.syntax:hover}{color:black;text-decoration:none;background-color:\#FF6060}
+%compatibility for hevea-1.1?/heeva-2.??
+\ifu\@tr@url
+\providecommand{\@tr@url}[1]{#1}\def\stx@id{NAME}\else
+\def\stx@id{id}\fi
+\newcommand{\@syntaxlocref}[2]
+{\@aelement{href="\@print{#}\@tr@url{#1}" class="syntax"}{#2}}
+\newcommand{\@syntaxaname}[2]
+{\@aelement{\stx@id="#1" class="syntax"}{#2}}
+%%Refer to anchor, internal :
+%#1 -> anchor #2 -> visible tag
+\def\@ref@anchor#1#2{%
+\@ifundefined{stx@#1@exists}
+{\stx@warning{#1}{Undefined non-terminal: '#1'}#2}
+{\@syntaxlocref{#1}{#2}}}
+%%Refer to anchor
+\def\ref@anchor#1{%
+\ifu\csname stx@#1@alias\endcsname
+\@ref@anchor{#1}{#1}\else
+\@ref@anchor{\csname stx@#1@alias\endcsname}{#1}\fi}
+\def\stx@exists#1{\def\csname stx@#1@exists\endcsname{}}
+%%Define anachor
+\def\def@anchor#1{%
+\@ifundefined{stx@#1}
+{{\@nostyle\@auxdowrite{\string\stx@exists\{#1\}}}%
+\gdef\csname stx@#1\endcsname{}\@syntaxaname{#1}{#1}}
+{\@ifundefined{stx@#1@silent}
+{\hva@warn{Redefinition of non-terminal '#1'}#1}
+{\ref@anchor{#1}}}}
+%%%Change \@anchor and initial definition, for html only, of course!
+\ifhtml
+\def\set@name{\let\@anchor\def@anchor}
+\let\@anchor\ref@anchor
+\else
+\def\set@name{}
+\def\@anchor{}
+\fi
+%%%Format non-terminal
+\def\nt#1{\textit{\maroon#1}}
+%%%Link for non-terminal and format
+\def\nonterm#1{\addspace\nt{\@anchor{#1}}\spacetrue}
+\def\brepet{\addspace\{}
+\def\erepet{\}}
+\def\boption{\addspace[}
+\def\eoption{]}
+\def\brepets{\addspace\{}
+\def\erepets{\}^+}
+\def\bparen{\addspace(}
+\def\eparen{)}
+\def\orelse{\mid \spacefalse}
+\def\is{ & ::= & \spacefalse }
+\def\alt{ \\ & \mid & \spacefalse }
+\def\sep{ \\ \\ \spacefalse }
+\def\cutline{}
+\def\emptystring{\epsilon}
+\def\syntax{\@open{div}{class="syntax"}$$\begin{array}{>{\set@name}rcl}\spacefalse}
+\def\endsyntax{\end{array}$$\@close{div}}
+\def\syntaxleft{\@open{div}{class="syntaxleft"}$\begin{array}{>{\set@name}rcl}\spacefalse}
+\def\endsyntaxleft{\end{array}$\@close{div}}
+\def\synt#1{$\spacefalse#1$}
--- /dev/null
+\newif\ifspace
+\def\addspace{\ifspace \; \spacefalse \fi}
+\def\token#1{\addspace\hbox{\tt #1} \spacetrue}
+\def\nonterm#1{\addspace\nt{#1} \spacetrue}
+\def\nt#1{\hbox{\sl #1\/}}
+\def\brepet{\addspace\{}
+\def\erepet{\}}
+\def\boption{\addspace[}
+\def\eoption{]}
+\def\brepets{\addspace\{}
+\def\erepets{\}^+}
+\def\bparen{\addspace(}
+\def\eparen{)}
+\def\orelse{\mid \spacefalse}
+\def\is{ & ::= & \spacefalse }
+\def\alt{ \\ & \mid & \spacefalse }
+\def\cutline{ \\ & & \spacefalse }
+\def\sep{ \\[2mm] \spacefalse }
+\def\emptystring{\epsilon}
+\def\syntax{$$\begin{array}{rrl}\spacefalse}
+\def\endsyntax{\end{array}$$}
+\def\syntaxleft{$\begin{array}{rrl}\spacefalse}
+\def\endsyntaxleft{\end{array}$}
+\let\oldldots=\ldots
+\def\ldots{\spacefalse\oldldots}
+\def\synt#1{$\spacefalse#1$}
--- /dev/null
+\newif\ifspace
+\def\addspace{\ifspace\ \spacefalse\fi}
+\def\token#1{\addspace\hbox{\tt #1}\spacetrue\ignorespaces}
+%%% \def\nonterm#1{\addspace\hbox{\tt <#1>}\spacetrue\ignorespaces}
+\def\nonterm#1{\addspace\hbox{\it #1}\spacetrue\ignorespaces}
+\def\brepet{\addspace\hbox to1em{$\{$\hfil}\ignorespaces}
+\def\erepet{\hbox to1em{$\}$\hfil}\ignorespaces}
+\def\boption{\addspace[\ignorespaces}
+\def\eoption{]\ignorespaces}
+\def\brepets{\brepet\ignorespaces}
+\def\erepets{\erepet+\ignorespaces}
+\def\bparen{\addspace(\ignorespaces}
+\def\eparen{)\ignorespaces}
+\def\orelse{~\hbox to1em{$|$\hfil}~\spacefalse\ignorespaces}
+\def\is{& ::= & \spacefalse\ignorespaces}
+\def\alt{\\ & \hbox to1em{$|$\hfil} & \spacefalse }
+\def\sep{\\[\baselineskip] \spacefalse}
+\def\emptystring{nothing}
+\def\syntax{\begin{center}\begin{tabular}{rrl}\spacefalse\ignorespaces}
+\def\endsyntax{\end{tabular}\end{center}}
+\def\ldots{\spacefalse...\ignorespaces}
+\def\synt#1{$\spacefalse#1$}
--- /dev/null
+TOPDIR=$(abspath ../..)
+include $(TOPDIR)/Makefile.tools
+MANUAL=$(TOPDIR)/manual/manual
+
+.PHONY: all
+all: check-cross-references check-stdlib
+
+cross-reference-checker: cross_reference_checker.ml
+ $(OCAMLC) $(TOPDIR)/compilerlibs/ocamlcommon.cma -I $(TOPDIR)/parsing \
+ -I $(TOPDIR)/driver \
+ cross_reference_checker.ml -o cross-reference-checker
+
+check-cross-references: cross-reference-checker
+ $(OCAMLRUN) ./cross-reference-checker \
+ -auxfile $(MANUAL)/texstuff/manual.aux \
+ $(TOPDIR)/utils/warnings.ml \
+ $(TOPDIR)/bytecomp/translmod.ml
+
+check-stdlib:
+ ./check-stdlib-modules $(TOPDIR)
--- /dev/null
+These tests have for objective to test the consistency between the manual and
+the rest of the compiler sources:
+
+- `cross_reference_checker.ml` checks that reference to the manual from the
+ compiler sources are still accurate.
+
+- `check-stdlib-modules` checks that all stdlib modules are linked from the
+ main entry of the stdlib in the manual: `manual/manual/library/stdlib.etex`
--- /dev/null
+#!/bin/sh
+
+TMPDIR="${TMPDIR:-/tmp}"
+
+(cd $1/stdlib; ls -1 *.mli) | sed -e 's/\.mli//' >$TMPDIR/stdlib-$$-files
+cut -c 1 $TMPDIR/stdlib-$$-files | tr a-z A-Z >$TMPDIR/stdlib-$$-initials
+cut -c 2- $TMPDIR/stdlib-$$-files \
+| paste -d '\0' $TMPDIR/stdlib-$$-initials - >$TMPDIR/stdlib-$$-modules
+
+exitcode=0
+for i in `cat $TMPDIR/stdlib-$$-modules`; do
+ case $i in
+ Stdlib | Camlinternal* | *Labels | Obj | Pervasives) continue;;
+ esac
+ grep -q -e '"'$i'" & p\.~\\pageref{'$i'} &' $1/manual/manual/library/stdlib.etex || {
+ echo "Module $i is missing from stdlib.etex." >&2
+ exitcode=2
+ }
+done
+
+rm -f $TMPDIR/stdlib-$$-*
+
+exit $exitcode
--- /dev/null
+(** Check reference to manual section in ml files
+
+ [cross-reference-cheker -auxfile tex.aux src.ml ]
+ checks that all expression and let bindings in [src.ml] annotated
+ with [[@manual.ref "tex_label"]] are integer tuple literals, e.g
+ {[
+ let[@manual.ref "sec:major"] ref = 1, 1
+ (* or *)
+ let ref = (3 [@manual.ref "ch:pentatonic"])
+ ]}
+ and that their values are consistent with the computed references for the
+ payload labels (e.g "sec:major", "ch:pentatonic") present in the TeX
+ auxiliary file [tex.aux]
+
+*)
+
+
+(** {1 Error printing } *)
+type error =
+ | Reference_mismatch of
+ {loc:Location.t; label:string; ocaml:int list; tex:int list}
+ | Unknown_label of Location.t * string
+ | Tuple_expected of Location.t
+ | No_aux_file
+ | Wrong_attribute_payload of Location.t
+
+let pp_ref ppf = Format.pp_print_list ~pp_sep:( fun ppf () ->
+ Format.pp_print_string ppf ".") Format.pp_print_int ppf
+
+let print_error error =
+ Location.report_error Format.std_formatter @@ match error with
+ | Tuple_expected loc ->
+ Location.errorf ~loc
+ "Integer tuple expected after manual reference annotation@."
+ | Unknown_label (loc,label) ->
+ Location.errorf ~loc
+ "@[<hov>Unknown manual label:@ %s@]@." label
+ | Reference_mismatch r ->
+ Location.errorf ~loc:r.loc
+ "@[<v 2>References for label %S do not match:@,\
+ OCaml side %a,@,\
+ manual %a@]@."
+ r.label
+ pp_ref r.ocaml
+ pp_ref r.tex
+ | No_aux_file ->
+ Location.errorf "No aux file provided@."
+ | Wrong_attribute_payload loc ->
+ Location.errorf ~loc "Wrong payload for \"@manual.ref\"@."
+
+
+(** {1 Main types} *)
+
+(** Maps of ocaml reference to manual labels *)
+module Refs = Map.Make(String)
+
+(** Reference extracted from TeX aux files *)
+type tex_reference =
+ { label: string;
+ pos: int list;
+ level: string
+ }
+
+type status = Ok | Bad | Unknown
+
+(** Reference extracted from OCaml source files *)
+type ml_reference = { loc: Location.t; pos: int list; status:status }
+
+(** {1 Consistency check } *)
+
+let check_consistency (ref:tex_reference) {loc; pos; _ } =
+ if ref.pos = pos then
+ { loc; pos; status = Ok }
+ else begin
+ print_error @@ Reference_mismatch {loc;label=ref.label;tex=ref.pos;ocaml=pos};
+ {loc; pos; status = Bad }
+ end
+
+let rec check_final_status label error = function
+ | { status = Ok; _ } -> error
+ | { status = Bad; _ } -> true
+ | { status = Unknown; loc; _} ->
+ print_error (Unknown_label (loc,label));
+ true
+
+(** {1 Data extraction from TeX side} *)
+
+module TeX = struct
+
+ (** Read reference information from a line of the aux file *)
+ let scan s =
+ try
+ Scanf.sscanf s
+ "\\newlabel{%s@}{{%s@}{%_d}{%_s@}{%s@.%_s@}{%_s@}}"
+ (fun label position_string level ->
+ let pos =
+ List.map int_of_string (String.split_on_char '.' position_string) in
+ Some {label;level;pos} )
+ with
+ | Scanf.Scan_failure _ -> None
+ | Failure _ -> None
+
+ let check_line refs line =
+ match scan line with
+ | None -> refs
+ | Some ref ->
+ match Refs.find_opt ref.label refs with
+ | None -> refs
+ | Some l ->
+ Refs.add ref.label
+ (List.map (check_consistency ref) l)
+ refs
+
+ let check_all aux refs =
+ let chan = open_in aux in
+ let rec lines refs =
+ let s = try Some (input_line chan) with End_of_file -> None in
+ match s with
+ | None -> refs
+ | Some line ->
+ lines @@ check_line refs line in
+ let refs = lines refs in
+ close_in chan;
+ let error = Refs.fold (fun label ocaml_refs error ->
+ List.fold_left (check_final_status label) error ocaml_refs)
+ refs false in
+ if error then exit 2 else exit 0
+end
+
+(** {1 Extract references from Ocaml source files} *)
+module OCaml_refs = struct
+
+ let parse ppf sourcefile =
+ Pparse.parse_implementation ppf ~tool_name:"manual_cross_reference_check"
+ sourcefile
+
+ (** search for an attribute [[@manual.ref "tex_label_name"]] *)
+ let manual_reference_attribute (s, payload) =
+ if s.Location.txt = "manual.ref" then
+ match payload with
+ | Parsetree.(
+ PStr [{pstr_desc= Pstr_eval
+ ({ pexp_desc = Pexp_constant Pconst_string (s,_) },_) } ] ) ->
+ Some s
+ | _ -> print_error (Wrong_attribute_payload s.Location.loc);
+ Some "" (* triggers an error *)
+ else
+ None
+
+ let rec label_from_attributes = function
+ | [] -> None
+ | a :: q -> match manual_reference_attribute a with
+ | Some _ as x -> x
+ | None -> label_from_attributes q
+
+ let int e =
+ let open Parsetree in
+ match e.pexp_desc with
+ | Pexp_constant Pconst_integer (s, _ ) -> int_of_string s
+ | _ -> raise Exit
+
+ let int_list l =
+ try Some (List.map int l) with
+ | Exit -> None
+
+ (** We keep a list of OCaml-side references to the same label *)
+ let add_ref label ref refs =
+ let l = match Refs.find_opt label refs with
+ | None -> [ref]
+ | Some l -> ref :: l in
+ Refs.add label l refs
+
+ let inner_expr loc e =
+ let tuple_expected () = print_error (Tuple_expected loc) in
+ match e.Parsetree.pexp_desc with
+ | Parsetree.Pexp_tuple l ->
+ begin match int_list l with
+ | None -> tuple_expected (); []
+ | Some pos -> pos
+ end
+ | Parsetree.Pexp_constant Pconst_integer (n,_) ->
+ [int_of_string n]
+ | _ -> tuple_expected (); []
+
+ (** extract from [let[@manual.ref "label"] x= 1, 2] *)
+ let value_binding m iterator vb =
+ let open Parsetree in
+ begin match label_from_attributes vb.pvb_attributes with
+ | None -> ()
+ | Some label ->
+ let pos = inner_expr vb.pvb_loc vb.pvb_expr in
+ m := add_ref label {loc = vb.pvb_loc; pos; status = Unknown } !m
+ end;
+ iterator.Ast_iterator.expr iterator vb.pvb_expr
+
+
+ (** extract from [ (1,2)[@manual.ref "label"]] *)
+ let expr m iterator e =
+ let open Parsetree in
+ begin match label_from_attributes e.pexp_attributes with
+ | None -> ()
+ | Some label ->
+ let pos = inner_expr e.pexp_loc e in
+ m := add_ref label {loc = e.pexp_loc; pos; status = Unknown } !m
+ end;
+ Ast_iterator.default_iterator.expr iterator e
+
+ let from_ast m ast =
+ let iterator =
+ let value_binding = value_binding m in
+ let expr = expr m in
+ Ast_iterator.{ default_iterator with value_binding; expr } in
+ iterator.structure iterator ast
+
+ let from_file m f =
+ from_ast m @@ parse Format.std_formatter f
+end
+
+
+(** {1 Argument handling and main function } *)
+
+let usage =
+ "cross-reference-check -auxfile [file.aux] file_1 ... file_n checks that \
+ the cross reference annotated with [@manual_cross_reference] are consistent \
+ with the provided auxiliary TeX file"
+
+(** the auxiliary file containing reference to be checked *)
+let aux_file = ref None
+
+let args =
+ [
+ "-auxfile",Arg.String (fun s -> aux_file := Some s),
+ "set the reference file"
+ ]
+
+let () =
+ let m = ref Refs.empty in
+ Arg.parse args (OCaml_refs.from_file m) usage;
+ match !aux_file with
+ | None -> print_error No_aux_file; exit 2
+ | Some aux ->
+ let error = TeX.check_all aux !m in
+ if error then exit 2 else exit 0
--- /dev/null
+transf.ml
+texquote2
+htmltransf.ml
+transf
+htmlgen
+htmlquote
+latexscan.ml
+dvi2txt
+caml-tex2
+*.dSYM
+*.cm[io]
+*.o
--- /dev/null
+transf.ml
+texquote2
+htmltransf.ml
+transf
+htmlgen
+htmlquote
+latexscan.ml
+dvi2txt
+caml-tex2
+*.dSYM
+*.cm[io]
--- /dev/null
+TOPDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/str -I $(OTOPDIR)/otherlibs/unix
+include $(TOPDIR)/Makefile.tools
+
+CFLAGS=-g -O
+
+all: texquote2 transf htmlquote htmlgen dvi2txt caml-tex2
+
+dvi2txt:
+ cd dvi_to_txt; ${MAKE}
+
+transf: transf.cmo htmltransf.cmo transfmain.cmo
+ $(OCAMLC) -o transf -g transf.cmo htmltransf.cmo transfmain.cmo
+
+transf.ml: transf.mll
+ $(OCAMLLEX) transf.mll
+
+htmltransf.ml: htmltransf.mll
+ $(OCAMLLEX) htmltransf.mll
+
+htmlgen: latexmacros.cmo latexscan.cmo latexmain.cmo
+ $(OCAMLC) -o htmlgen -g latexmacros.cmo latexscan.cmo latexmain.cmo
+
+latexscan.ml: latexscan.mll
+ ocamllex latexscan.mll
+
+caml-tex2: caml_tex2.ml
+ $(OCAMLC) $(TOPDIR)/compilerlibs/ocamlcommon.cma -I $(TOPDIR)/parsing \
+ -o caml-tex2 str.cma unix.cma caml_tex2.ml
+
+.SUFFIXES:
+.SUFFIXES: .ml .cmo .mli .cmi .c
+
+.ml.cmo:
+ $(OCAMLC) -c $<
+
+.mli.cmi:
+ $(OCAMLC) -c $<
+
+.c:
+ $(CC) $(CFLAGS) -o $@ $<
+
+clean:
+ rm -f transf.ml latexscan.ml htmltransf.ml
+ rm -f texquote2 transf htmlquote htmlgen dvi2txt
+ rm -f transf.ml latex.ml
+ rm -f *.o *.cm? *.cmxa
+ rm -f *~ #*#
+ cd dvi_to_txt; ${MAKE} clean
+
+latexmacros.cmo: latexmacros.cmi
+latexmain.cmo: latexscan.cmo
+latexscan.cmo: latexmacros.cmi
+transfmain.cmo: transf.cmo htmltransf.cmo
--- /dev/null
+#!/usr/bin/perl
+
+$camllight = "TERM=dumb ocaml";
+$camlbegin = "\\caml\n";
+$camlend = "\\endcaml\n";
+$camlin = "\\?";
+$camlout = "\\:";
+$camlblank = "\\;\n";
+
+$linelen = 72;
+$output = "";
+$cut_at_blanks = 0;
+
+while ($#ARGV >= 0) {
+ $_ = $ARGV[0];
+ last unless (/^-/);
+ $linelen = $ARGV[1], shift, shift, next if (/^-n$/);
+ $output = $ARGV[1], shift, shift, next if (/^-o$/);
+ $camllight = $ARGV[1], shift, shift, next if (/^-caml$/);
+ $cut_at_blanks = 1, shift, next if (/^-w$/);
+ printf STDERR ("Unknown option '%s', ignored\n", $_);
+ shift;
+}
+
+# First pass: extract the Caml phrases to evaluate
+
+open(ML, "> .input.ml") || die("Cannot create .input.ml : $!");
+
+foreach $infile (@ARGV) {
+ open(IN, $infile) || die("Cannot open $infile : $!");
+ while(<IN>) {
+ if (m/^\\begin{caml_(example|example\*|eval)}\s*$/) {
+ while(<IN>) {
+ last if m/^\\end{caml_(example|example\*|eval)}\s*$/;
+ print ML $_;
+ }
+ }
+ }
+ close(IN);
+}
+
+close(ML);
+
+# Feed the phrases to a Caml toplevel
+
+open(TOPLEVEL, "$camllight 2>&1 < .input.ml |") ||
+ die("Cannot start camllight : $!");
+
+<TOPLEVEL>; <TOPLEVEL>; # skip the banner
+$lastread = <TOPLEVEL>;
+$lastread =~ s/^# //;
+
+# Second pass: shuffle the TeX source and the output of the toplevel
+
+if ($output) {
+ if ($output eq "-") {
+ open(OUT, ">&STDOUT");
+ } else {
+ open(OUT, ">$output") || die("Cannot create $output: $!");
+ }
+}
+
+foreach $infile (@ARGV) {
+ open(IN, $infile) || die("Cannot open $infile: $!");
+ if (! $output) {
+ $outfile = $infile;
+ $outfile =~ s/\.tex$//;
+ open(OUT, "> $outfile.ml.tex") || die("Cannot create $outfile.ml.tex: $!");
+ }
+ while(<IN>) {
+ if (m/^\\begin{caml_example(\*?)}\s*$/) {
+ $omit_answer = $1; # true if caml_example*, false if caml_example
+ print OUT $camlbegin;
+ $severalphrases = 0;
+ while(<IN>) {
+ last if m/\\end{caml_example\*?}\s*$/;
+ print OUT $camlblank if ($severalphrases);
+ while(1) {
+ s/\\/\\\\/g;
+ print OUT $camlin, $_;
+ last if m/;; *$/;
+ $_ = <IN>;
+ }
+ while ($lastread =~ s/^ //) { }
+ while($lastread) {
+ last if $lastread =~ s/^# //;
+ print STDERR $lastread;
+ if (! $omit_answer) {
+ while (length($lastread) > $linelen) {
+ if ($cut_at_blanks) {
+ $cutpos = rindex($lastread, ' ', $linelen);
+ if ($cutpos == -1) { $cutpos = $linelen; } else { $cutpos++; }
+ } else {
+ $cutpos = $linelen;
+ }
+ $line = substr($lastread, 0, $cutpos);
+ $line =~ s/\\/\\\\/g;
+ print OUT $camlout, $line, "\n";
+ $lastread = substr($lastread, $cutpos,
+ length($lastread) - $cutpos);
+ }
+ $lastread =~ s/\\/\\\\/g;
+ print OUT $camlout, $lastread;
+ }
+ $lastread = <TOPLEVEL>;
+ }
+ $severalphrases = 1;
+ }
+ print OUT $camlend;
+ }
+ elsif (m/^\\begin{caml_eval}\s*$/) {
+ while(<IN>) {
+ last if m/^\\end{caml_eval}\s*$/;
+ if (m/;; *$/) {
+ while ($lastread =~ s/^ //) { }
+ while($lastread) {
+ last if $lastread =~ s/^#//;
+ print STDERR $lastread;
+ $lastread = <TOPLEVEL>;
+ }
+ }
+ }
+ }
+ else {
+ print OUT $_;
+ }
+ }
+ close(IN);
+}
+
+close(TOPLEVEL);
--- /dev/null
+(* $Id$ *)
+
+open StdLabels
+open Printf
+open Str
+
+let camlbegin = "\\caml"
+let camlend = "\\endcaml"
+let camlin = {|\\?\1|}
+let camlout = {|\\:\1|}
+let camlbunderline = "\\<"
+let camleunderline = "\\>"
+
+let start newline out s args =
+ Printf.fprintf out "%s%s" camlbegin s;
+ List.iter (Printf.fprintf out "{%s}") args;
+ if newline then Printf.fprintf out "\n"
+
+let stop newline out s =
+ Printf.fprintf out "%s%s" camlend s;
+ if newline then Printf.fprintf out "\n"
+
+let code_env ?(newline=true) env out s =
+ Printf.fprintf out "%a%s\n%a"
+ (fun ppf env -> start false ppf env []) env s (stop newline) env
+
+let main = "example"
+type example_mode = Toplevel | Verbatim | Signature
+let string_of_mode = function
+ | Toplevel -> "toplevel"
+ | Verbatim -> "verbatim"
+ | Signature -> "signature"
+
+let input_env = "input"
+let ok_output ="output"
+let error ="error"
+let warning ="warn"
+let phrase_env = ""
+
+
+let camllight = ref "TERM=norepeat ocaml"
+let verbose = ref true
+let linelen = ref 72
+let outfile = ref ""
+let cut_at_blanks = ref false
+let files = ref []
+
+let _ =
+ Arg.parse ["-n", Arg.Int (fun n -> linelen := n), "line length";
+ "-o", Arg.String (fun s -> outfile := s), "output";
+ "-caml", Arg.String (fun s -> camllight := s), "toplevel";
+ "-w", Arg.Set cut_at_blanks, "cut at blanks";
+ "-v", Arg.Bool (fun b -> verbose := b ), "output result on stderr"
+ ]
+ (fun s -> files := s :: !files)
+ "caml-tex2: "
+
+let (~!) =
+ let memo = ref [] in
+ fun key ->
+ try List.assq key !memo
+ with Not_found ->
+ let data = Str.regexp key in
+ memo := (key, data) :: !memo;
+ data
+
+(** The Output module deals with the analysis and classification
+ of the interpreter output and the parsing of status-related options
+ or annotations for the caml_example environment *)
+module Output = struct
+
+ (** Interpreter output status *)
+ type status =
+ | Ok
+ | Warning of int
+ | Error
+
+ type kind =
+ | Annotation (** Local annotation: [ [@@expect (*annotation*) ] ]*)
+ | Option (** Global environment option:
+ [\begin{caml_example}[option[=value]]
+ ...
+ \end{caml_example}] *)
+
+ (** Pretty printer for status *)
+ let pp_status ppf = function
+ | Error -> Printf.fprintf ppf "error"
+ | Ok -> Printf.fprintf ppf "ok"
+ | Warning n -> Printf.fprintf ppf "warning %d" n
+
+ (** Pretty printer for status preceded with an undefined determinant *)
+ let pp_a_status ppf = function
+ | Error -> Printf.fprintf ppf "an error"
+ | Ok -> Printf.fprintf ppf "an ok"
+ | Warning n -> Printf.fprintf ppf "a warning %d" n
+
+ (** {1 Related latex environment } *)
+ let env = function
+ | Error -> error
+ | Warning _ -> warning
+ | Ok -> ok_output
+
+ (** {1 Exceptions } *)
+ exception Parsing_error of kind * string
+
+ type source = { file:string; lines:int * int; phrase:string; output:string }
+ type unexpected_report = {source:source; expected:status; got:status}
+ exception Unexpected_status of unexpected_report
+
+ let print_source ppf {file; lines = (start, stop); phrase; output} =
+ Printf.fprintf ppf "%s, lines %d to %d:\n\"\n%s\n\"\n\"\n%s\n\"."
+ file start stop phrase output
+
+ let print_unexpected {source; expected; got} =
+ if expected = Ok then
+ Printf.eprintf
+ "Error when evaluating a caml_example environment in %a\n\
+ Unexpected %a status.\n\
+ If %a status was expected, add an [@@expect %a] annotation.\n"
+ print_source source
+ pp_status got
+ pp_a_status got
+ pp_status got
+ else
+ Printf.eprintf
+ "Error when evaluating a guarded caml_example environment in %a\n\
+ Unexpected %a status, %a status was expected.\n\
+ If %a status was in fact expected, change the status annotation to \
+ [@@expect %a].\n"
+ print_source source
+ pp_status got
+ pp_a_status expected
+ pp_a_status got
+ pp_status got;
+ flush stderr
+
+ let print_parsing_error k s =
+ match k with
+ | Option ->
+ Printf.eprintf
+ "Unknown caml_example option: [%s].\n\
+ Supported options are \"ok\",\"error\", or \"warning=n\" (with n \
+ a warning number).\n" s
+ | Annotation ->
+ Printf.eprintf
+ "Unknown caml_example phrase annotation: [@@expect %s].\n\
+ Supported annotations are [@@expect ok], [@@expect error],\n\
+ and [@@expect warning n] (with n a warning number).\n" s
+
+ (** {1 Output analysis} *)
+ let catch_error s =
+ if string_match ~!{|Error:|} s 0 then Some Error else None
+
+ let catch_warning s =
+ if string_match ~!{|Warning \([0-9]+\):|} s 0 then
+ Some (Warning (int_of_string @@ matched_group 1 s))
+ else
+ None
+
+ let status s = match catch_warning s, catch_error s with
+ | Some w, _ -> w
+ | None, Some e -> e
+ | None, None -> Ok
+
+ (** {1 Parsing caml_example options } *)
+
+ (** Parse [warning=n] options for caml_example options *)
+ let parse_warning s =
+ if string_match ~!{|warning=\([0-9]+\)|} s 0 then
+ Some (Warning (int_of_string @@ matched_group 1 s))
+ else
+ None
+
+ (** Parse [warning n] annotations *)
+ let parse_local_warning s =
+ if string_match ~!{|warning \([0-9]+\)|} s 0 then
+ Some (Warning (int_of_string @@ matched_group 1 s))
+ else
+ None
+
+ let parse_error s =
+ if s="error" then Some Error else None
+
+ let parse_ok s =
+ if s = "ok" then Some Ok else None
+
+ (** Parse the environment-wide expected status output *)
+ let expected s =
+ match parse_warning s, parse_error s with
+ | Some w, _ -> w
+ | None, Some e -> e
+ | None, None -> raise (Parsing_error (Option,s))
+
+ (** Parse the local (i.e. phrase-wide) expected status output *)
+ let local_expected s =
+ match parse_local_warning s, parse_error s, parse_ok s with
+ | Some w, _, _ -> w
+ | None, Some e, _ -> e
+ | None, None, Some ok -> ok
+ | None, None, None -> raise (Parsing_error (Annotation,s))
+
+end
+
+module Text_transform = struct
+
+ type kind =
+ | Underline
+ | Ellipsis
+
+ exception Intersection of
+ {line:int; file:string; left:kind; stop:int; start:int; right:kind}
+
+ let pp ppf = function
+ | Underline -> Format.fprintf ppf "underline"
+ | Ellipsis -> Format.fprintf ppf "ellipsis"
+
+ type t = { kind:kind; start:int; stop:int}
+ let escape_specials s =
+ let s1 = global_replace ~!"\\\\" "\\\\\\\\" s in
+ let s2 = global_replace ~!"'" "\\\\textquotesingle\\\\-" s1 in
+ let s3 = global_replace ~!"`" "\\\\textasciigrave\\\\-" s2 in
+ s3
+
+ let rec apply_transform input (pos,underline_stop,out) t =
+ if pos >= String.length input then pos, underline_stop, out
+ else match underline_stop with
+ | Some stop when stop <= t.start ->
+ let f = escape_specials (String.sub input ~pos ~len:(stop - pos)) in
+ let out = {|\>|} :: f :: out in
+ apply_transform input (stop,None,out) t
+ | _ ->
+ let out =
+ escape_specials (String.sub input ~pos ~len:(t.start - pos))::out in
+ match t.kind with
+ | Ellipsis -> t.stop, underline_stop, {|\ldots|} :: out
+ | Underline ->
+ t.start, Some t.stop, {|\<|} :: out
+
+ (** Check that all ellipsis are strictly nested inside underline transform
+ and that otherwise no transform starts before the end of the previous
+ transform in a list of transforms *)
+ type partition = U of t * t list | E of t
+ let check_partition line file l =
+ let init = Ellipsis, 0 in
+ let rec partition = function
+ | [] -> []
+ | {kind=Underline; _ } as t :: q -> underline t [] q
+ | {kind=Ellipsis; _ } as t :: q -> E t :: partition q
+ and underline u n = function
+ | [] -> end_underline u n []
+ | {kind=Underline; _ } :: _ as q -> end_underline u n q
+ | {kind=Ellipsis; _ } as t :: q ->
+ if t.stop < u.stop then underline u (t::n) q
+ else end_underline u n (t::q)
+ and end_underline u n l = U(u,List.rev n) :: partition l in
+ let check_elt (left,stop) t =
+ if t.start < stop then
+ raise (Intersection{line;file;left;stop;start=t.start;right=t.kind})
+ else
+ (t.kind,t.stop) in
+ let check acc = function
+ | E t -> check_elt acc t
+ | U(u,n) ->
+ let _ = check_elt acc u in
+ let _ = List.fold_left ~f:check_elt ~init n in
+ u.kind, u.stop in
+ List.fold_left ~f:check ~init (partition l)
+ |> ignore
+
+ let apply ts file line s =
+ let ts = List.sort (fun x y -> compare x.start y.start) ts in
+ check_partition line file ts;
+ let last, underline, ls =
+ List.fold_left ~f:(apply_transform s) ~init:(0,None,[]) ts in
+ let last, ls = match underline with
+ | None -> last, ls
+ | Some stop ->
+ let f = escape_specials (String.sub s ~pos:last ~len:(stop - last)) in
+ stop, {|\>|} :: f :: ls in
+ let ls =
+ let n = String.length s in
+ if last = n then ls else
+ escape_specials (String.sub s last (n-last)) :: ls in
+ String.concat "" (List.rev ls)
+end
+
+
+let caml_input, caml_output =
+ let cmd = !camllight ^ " 2>&1" in
+ try Unix.open_process cmd with _ -> failwith "Cannot start toplevel"
+let () =
+ at_exit (fun () -> ignore (Unix.close_process (caml_input, caml_output)));
+ ignore (input_line caml_input);
+ ignore (input_line caml_input)
+
+let read_output () =
+ let input = ref (input_line caml_input) in
+ input := replace_first ~!{|^#\( *\*\)* *|} "" !input;
+ (* the inner ( *\* )* group is here to clean the starting "*"
+ introduced for multiline comments *)
+ let underline =
+ if string_match ~!"Characters *\\([0-9]+\\)-\\([0-9]+\\):$" !input 0
+ then
+ let start = int_of_string (matched_group 1 !input)
+ and stop = int_of_string (matched_group 2 !input) in
+ input := input_line caml_input;
+ Text_transform.[{kind=Underline; start; stop}]
+ else []
+ in
+ let output = Buffer.create 256 in
+ let first_line = ref true in
+ while not (string_match ~!".*\"end_of_input\"$" !input 0) do
+ if !verbose then prerr_endline !input;
+ if not !first_line then Buffer.add_char output '\n' else first_line:=false;
+ Buffer.add_string output !input;
+ input := input_line caml_input;
+ done;
+ Buffer.contents output, underline
+
+exception Missing_double_semicolon of string * int
+
+exception Missing_mode of string * int
+
+type incompatibility =
+ | Signature_with_visible_answer of string * int
+exception Incompatible_options of incompatibility
+
+exception Phrase_parsing of string
+
+module Ellipsis = struct
+ (** This module implements the extraction of ellipsis locations
+ from phrases.
+
+ An ellipsis is either an [[@ellipsis]] attribute, or a pair
+ of [[@@@ellipsis.start]...[@@@ellipsis.stop]] attributes. *)
+
+ exception Unmatched_ellipsis of {kind:string; start:int; stop:int}
+ (** raised when an [[@@@ellipsis.start]] or [[@@@ellipsis.stop]] is
+ not paired with another ellipsis attribute *)
+
+ exception Nested_ellipses of {first:int ; second:int }
+ (** raised by [[@@@ellipsis.start][@@@ellipsis.start]] *)
+
+ let extract f x =
+ let transforms = ref [] in
+ let last_loc = ref Location.none in
+ let left_mark = ref None (* stored position of [@@@ellipsis.start]*) in
+ let location _this loc =
+ (* we rely on the fact that the default iterator call first
+ the location subiterator, then the attribute subiterator *)
+ last_loc := loc in
+ let attribute _this (attr,_) =
+ let name = attr.Location.txt in
+ let loc = !last_loc in
+ let start = loc.Location.loc_start.Lexing.pos_cnum in
+ let attr_start = attr.Location.loc.loc_start.Lexing.pos_cnum in
+ let attr_stop = 1 + attr.Location.loc.loc_end.Lexing.pos_cnum in
+ let stop = loc.Location.loc_end.Lexing.pos_cnum in
+ let check_nested () = match !left_mark with
+ | Some (first,_) -> raise (Nested_ellipses {first; second=attr_start})
+ | None -> () in
+ match name with
+ | "ellipsis" ->
+ check_nested ();
+ transforms :=
+ {Text_transform.kind=Ellipsis; start; stop=max attr_stop stop }
+ :: !transforms
+ | "ellipsis.start" ->
+ check_nested ();
+ left_mark := Some (start, stop)
+ | "ellipsis.stop" ->
+ begin match !left_mark with
+ | None -> raise (Unmatched_ellipsis {kind="right"; start; stop})
+ | Some (start, _ ) ->
+ transforms := {kind=Ellipsis; start ; stop } :: !transforms;
+ left_mark := None
+ end
+ | _ -> ()
+ in
+ f {Ast_iterator.default_iterator with location; attribute} x;
+ (match !left_mark with
+ | None -> ()
+ | Some (start,stop) ->
+ raise (Unmatched_ellipsis {kind="left"; start; stop })
+ );
+ !transforms
+
+ let find fname mode s =
+ let lex = Lexing.from_string s in
+ Location.init lex fname;
+ Location.input_name := fname;
+ Location.input_lexbuf := Some lex;
+ try
+ match mode with
+ | Toplevel -> begin
+ match Parse.toplevel_phrase lex with
+ | Ptop_dir _ -> []
+ | Ptop_def str -> extract (fun it -> it.structure it) str
+ end
+ | Verbatim ->
+ extract (fun it -> it.structure it) (Parse.implementation lex)
+ | Signature ->
+ extract (fun it -> it.signature it) (Parse.interface lex)
+ with Syntaxerr.Error _ -> raise (Phrase_parsing s)
+
+end
+
+let process_file file =
+ prerr_endline ("Processing " ^ file);
+ let ic = try open_in file with _ -> failwith "Cannot read input file" in
+ let phrase_start = ref 1 and phrase_stop = ref 1 in
+ let incr_phrase_start () =
+ incr phrase_start;
+ phrase_stop := !phrase_start in
+ let oc =
+ try if !outfile = "-" then
+ stdout
+ else if !outfile = "" then
+ open_out (replace_first ~!"\\.tex$" "" file ^ ".ml.tex")
+ else
+ open_out_gen [Open_wronly; Open_creat; Open_append; Open_text]
+ 0x666 !outfile
+ with _ -> failwith "Cannot open output file" in
+ let fatal fmt =
+ Format.kfprintf
+ (fun ppf -> Format.fprintf ppf "@]@."; close_in ic; close_out oc; exit 1)
+ Format.err_formatter ("@[<hov 2> Error " ^^ fmt) in
+ let re_spaces = "[ \t]*" in
+ let re_start = ~!(
+ {|\\begin{caml_example\(\*?\)}|} ^ re_spaces
+ ^ {|\({toplevel}\|{verbatim}\|{signature}\)?|} ^ re_spaces
+ ^ {|\(\[\(.*\)\]\)?|} ^ re_spaces
+ ^ "$"
+ ) in
+ try while true do
+ let input = ref (input_line ic) in
+ incr_phrase_start();
+ if string_match re_start !input 0
+ then begin
+ let omit_answer = matched_group 1 !input = "*" in
+ let mode =
+ match matched_group 2 !input with
+ | exception Not_found -> raise (Missing_mode(file, !phrase_stop))
+ | "{toplevel}" -> Toplevel
+ | "{verbatim}" -> Verbatim
+ | "{signature}" -> Signature
+ | _ -> assert false in
+ if mode = Signature && not omit_answer then raise
+ (Incompatible_options(
+ Signature_with_visible_answer(file,!phrase_stop))
+ );
+ let explicit_stop = match mode with
+ | Verbatim | Signature -> false
+ | Toplevel -> true in
+ let global_expected = try Output.expected @@ matched_group 4 !input
+ with Not_found -> Output.Ok in
+ start true oc main [string_of_mode mode];
+ let first = ref true in
+ let read_phrase () =
+ let phrase = Buffer.create 256 in
+ let rec read () =
+ let input = incr phrase_stop; input_line ic in
+ let implicit_stop =
+ if string_match ~!"\\\\end{caml_example\\*?}[ \t]*$"
+ input 0
+ then
+ begin
+ if !phrase_stop = 1 + !phrase_start then
+ raise End_of_file
+ else if explicit_stop then
+ raise @@ Missing_double_semicolon (file,!phrase_stop)
+ else
+ true
+ end
+ else false in
+ if Buffer.length phrase > 0 then Buffer.add_char phrase '\n';
+ let stop =
+ implicit_stop ||
+ ( not (mode = Signature)
+ && string_match ~!"\\(.*\\)[ \t]*;;[ \t]*$" input 0 )
+ in
+ if not stop then (
+ Buffer.add_string phrase input; read ()
+ )
+ else begin
+ decr phrase_stop;
+ let last_input = if implicit_stop then "" else matched_group 1 input in
+ let expected =
+ if string_match ~!{|\(.*\)\[@@expect \(.*\)\]|} last_input 0 then
+ ( Buffer.add_string phrase (matched_group 1 last_input);
+ Output.local_expected @@ matched_group 2 last_input )
+ else
+ (Buffer.add_string phrase last_input; global_expected)
+ in
+ if not implicit_stop then Buffer.add_string phrase ";;";
+ implicit_stop, Buffer.contents phrase, expected
+ end in
+ read ()
+ in
+ try while true do
+ let implicit_stop, phrase, expected = read_phrase () in
+ let ellipses = Ellipsis.find file mode phrase in
+ if mode = Signature then fprintf caml_output "module type Wrap = sig\n";
+ fprintf caml_output "%s%s%s" phrase
+ (if mode = Signature then "\nend" else "")
+ (if implicit_stop then ";;\n" else "\n");
+ flush caml_output;
+ output_string caml_output "\"end_of_input\";;\n";
+ flush caml_output;
+ let output, underline = read_output () in
+ let status = Output.status output in
+ if status <> expected then (
+ let source = Output.{
+ file;
+ lines = (!phrase_start, !phrase_stop);
+ phrase;
+ output
+ } in
+ raise (Output.Unexpected_status
+ {Output.got=status; expected; source} ) )
+ else ( incr phrase_stop; phrase_start := !phrase_stop );
+ let phrase =
+ Text_transform.apply (underline @ ellipses)
+ file !phrase_stop phrase in
+ (* Special characters may also appear in output strings -Didier *)
+ let output = Text_transform.escape_specials output in
+ let phrase = global_replace ~!{|^\(.\)|} camlin phrase
+ and output = global_replace ~!{|^\(.\)|} camlout output in
+ start false oc phrase_env [];
+ code_env ~newline:omit_answer input_env oc phrase;
+ if not omit_answer then
+ code_env ~newline:false (Output.env status) oc output;
+ stop true oc phrase_env;
+ flush oc;
+ first := false;
+ if implicit_stop then raise End_of_file
+ done
+ with End_of_file -> phrase_start:= !phrase_stop; stop true oc main
+ end
+ else if string_match ~!"\\\\begin{caml_eval}[ \t]*$" !input 0
+ then begin
+ while input := input_line ic;
+ not (string_match ~!"\\\\end{caml_eval}[ \t]*$" !input 0)
+ do
+ fprintf caml_output "%s\n" !input;
+ if string_match ~!".*;;[ \t]*$" !input 0 then begin
+ flush caml_output;
+ output_string caml_output "\"end_of_input\";;\n";
+ flush caml_output;
+ ignore (read_output ())
+ end
+ done
+ end else begin
+ fprintf oc "%s\n" !input;
+ flush oc
+ end
+ done with
+ | End_of_file -> close_in ic; close_out oc
+ | Output.Unexpected_status r ->
+ ( Output.print_unexpected r; close_in ic; close_out oc; exit 1 )
+ | Output.Parsing_error (k,s) ->
+ ( Output.print_parsing_error k s;
+ close_in ic; close_out oc; exit 1 )
+ | Phrase_parsing s -> fatal "when parsing the following phrase:@ %s" s
+ | Missing_double_semicolon (file, line_number) ->
+ fatal
+ "when evaluating a caml_example environment in %s:@;\
+ missing \";;\" at line %d@]@." file (line_number-2)
+ | Missing_mode (file, line_number) ->
+ fatal "when parsing a caml_example environment in %s:@;\
+ missing mode argument at line %d,@ \
+ available modes {toplevel,verbatim}@]@."
+ file (line_number-2)
+ | Incompatible_options Signature_with_visible_answer (file, line_number) ->
+ fatal
+ "when parsing a caml_example environment in@ \
+ %s, line %d:@,\
+ the signature mode is only compatible with \"caml_example*\"@ \
+ Hint: did you forget to add \"*\"?@]@."
+ file (line_number-2);
+ | Text_transform.Intersection {line;file;left;stop;start;right} ->
+ fatal
+ "when evaluating a caml_example environment in %s, line %d:@ \
+ Textual transforms must be well-separated.@ The \"%a\" transform \
+ ended at %d,@ after the start at %d of another \"%a\" transform.@ \
+ Hind: did you try to elide a code fragment which raised a warning?\
+ @]@."
+ file (line-2)
+ Text_transform.pp left stop start Text_transform.pp right
+ | Ellipsis.Unmatched_ellipsis {kind;start;stop} ->
+ fatal "when evaluating a caml_example environment,@ \
+ the %s mark at position %d-%d was unmatched"
+ kind start stop
+ | Ellipsis.Nested_ellipses {first;second} ->
+ fatal "when evaluating a caml_example environment,@ \
+ there were two nested ellipsis attribute.@ The first one \
+ started at position %d,@ the second one at %d"
+ first second
+
+let _ =
+ if !outfile <> "-" && !outfile <> "" then begin
+ try close_out (open_out !outfile)
+ with _ -> failwith "Cannot open output file"
+ end;
+ List.iter process_file (List.rev !files)
--- /dev/null
+OBJS=io.o interp.o output.o main.o print.o print_rtf.o print_styl.o
+CFLAGS=-g
+
+../dvi2txt: $(OBJS)
+ $(CC) $(CFLAGS) -o ../dvi2txt $(OBJS)
+
+clean:
+ rm -f ../dvi2txt *.o *~ #*#
--- /dev/null
+enum {
+ SET_CHAR_0=0, SET_CHAR_127=127, SET1=128, SET2, SET3, SET4, SET_RULE,
+ PUT1, PUT2, PUT3, PUT4, PUT_RULE, NOP, BOP, EOP, PUSH, POP, RIGHT1,
+ RIGHT2, RIGHT3, RIGHT4, W0, W1, W2, W3, W4, X0, X1, X2, X3, X4, DOWN1,
+ DOWN2, DOWN3, DOWN4, Y0, Y1, Y2, Y3, Y4, Z0, Z1, Z2, Z3, Z4,
+ FNT_NUM_0=171, FNT_NUM_63=234, FNT1=235, FNT2, FNT3, FNT4, XXX1, XXX2,
+ XXX3, XXX4, FNT_DEF1, FNT_DEF2, FNT_DEF3, FNT_DEF4, PRE, POST, POST_POST
+};
--- /dev/null
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <assert.h>
+#include "io.h"
+#include "dvi.h"
+#include "output.h"
+
+#define SEEK_CUR 1
+
+int h, v, w, x, y, z, sp;
+int currfont;
+int encoding;
+int style;
+
+#define FONT_NAME_SIZE 31
+#define NUM_FONTS 256
+
+struct {
+ char name[FONT_NAME_SIZE+1];
+ int encoding;
+ int style;
+} font[NUM_FONTS];
+
+#define TYPEWRITER 0
+#define ROMAN 1
+#define MATH_ITALIC 2
+#define MATH_SYMBOL 3
+#define MATH_EXTENSION 4
+#define LINE_SEGMENTS 5
+#define CIRCLE_SEGMENTS 6
+#define LATEX_SYMBOLS 7
+
+char * transcode[] = {
+/* 0.......+.......1.......+.......2.......+.......3.......+.......4.......+.......5.......+.......6.......+.......7.......+....... */
+/* TYPEWRITER */
+ "GDTLXPSUPYO##################### !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~#",
+/* ROMAN */
+ "GDTLXPSUPYO***** 0'!\"#$%&'()*+,-./0123456789:;!=??@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\"]^.`abcdefghijklmnopqrstuvwxyz--\"~#",
+/* MATH_ITALIC */
+ "GDTLXPSUPYOabgdezhtiklmnxpystupxyoeuorsp----`'><0123456789.,</>*dABCDEFGHIJKLMNOPQRSTUVWXYZ#####labcdefghijklmnopqrstuvwxyzij###",
+/* MATH_SYMBOL */
+ "-.x*/###+-x/.ooo==##<><>==##<><><>||####<>||####'#####/|###0RIT##ABCDEFGHIJKLMNOPQRSTUVWXYZ###########{}<>||||\\|################",
+/* MATH_EXTENSION */
+ "()[]||||{}<>||##()[]||||{}<>||##()[]||||{}<>||##########################################################[]||||{}################",
+/* LINE_SEGMENTS */
+ "/||||| _ / / _/ // _ / / __// / _ / \\||||| \\ \\ \\ _\\ \\\\ _ \\ \\ __\\\\ \\ _ \\ ",
+/* CIRCLE_SEGMENTS */
+ " ",
+/* LATEX_SYMBOLS */
+ " <<>> U#O0 ~~[] "
+};
+
+#define STACK_SIZE 100
+
+struct { int sh, sv, sw, sx, sy, sz; } stack[STACK_SIZE];
+
+struct known_font_struct {
+ char * prefix;
+ int encoding, style;
+} known_fonts[] = {
+ "docrm", ROMAN, PLAIN,
+ "doctt", TYPEWRITER, MONOSPACED,
+ "docit", ROMAN, ITALICS,
+ "docbf", ROMAN, BOLD,
+ "docmi", MATH_ITALIC, PLAIN,
+ "cmsy", MATH_SYMBOL, PLAIN,
+ "cmex", MATH_EXTENSION, PLAIN,
+ "line", LINE_SEGMENTS, PLAIN,
+ "lcircle", CIRCLE_SEGMENTS, PLAIN,
+ "lasy", LATEX_SYMBOLS, PLAIN
+};
+
+void fontdef(input, fontnum)
+ FILE * input;
+ int fontnum;
+{
+ int a, l, i;
+
+ assert(fontnum >= 0 && fontnum < NUM_FONTS);
+ fseek(input, 12, SEEK_CUR); /* skip c, s and d parameters */
+ a = get8u(input);
+ l = get8u(input);
+ assert(l < FONT_NAME_SIZE);
+ fseek(input, a, SEEK_CUR); /* skip the "area" part */
+ fread(font[fontnum].name, 1, l, input); /* read the font name */
+ font[fontnum].name[l] = 0;
+ for (i = 0;
+ i < sizeof(known_fonts) / sizeof(struct known_font_struct);
+ i++) {
+ if (strncmp(font[fontnum].name, known_fonts[i].prefix,
+ strlen(known_fonts[i].prefix)) == 0) {
+ font[fontnum].encoding = known_fonts[i].encoding;
+ font[fontnum].style = known_fonts[i].style;
+ return;
+ }
+ }
+ fprintf(stderr, "Warning: unknown font `%s'\n", font[fontnum].name);
+ font[fontnum].encoding = ROMAN;
+ font[fontnum].style = PLAIN;
+}
+
+void setfont(fontnum)
+ int fontnum;
+{
+ currfont = fontnum;
+ encoding = font[fontnum].encoding;
+ style = font[fontnum].style;
+}
+
+int outchar(c)
+ int c;
+{
+ if (c < 0 || c > 127)
+ out(h, v, '#', PLAIN);
+ else
+ out(h, v, transcode[encoding][c], style);
+ return scalex;
+}
+
+void outrule(height, width)
+ int height, width;
+{
+ char c;
+ int dx, dy;
+
+ if (height <= 0 || width <= 0) return;
+ c = height >= width ? '|' : '-';
+ dy = 0;
+ do {
+ dx = 0;
+ do {
+ out(h + dx, v - dy, c, PLAIN);
+ dx += scalex;
+ } while (dx <= width);
+ dy += scaley;
+ } while (dy < height);
+}
+
+void interprete(input)
+ FILE * input;
+{
+ int c, n, height, width, mag;
+
+ sp = 0;
+ c = get8u(input);
+ n = get8u(input);
+ if (c != PRE || n != 2) {
+ fprintf(stderr, "File does not start with DVI preamble.\n");
+ exit(2);
+ }
+ (void) get32s(input);
+ (void) get32s(input);
+ mag = get32s(input);
+ scalex = SCALEX * mag / 1000;
+ scaley = SCALEY * mag / 1000;
+ n = get8u(input);
+ fseek(input, n, SEEK_CUR); /* skip comment */
+
+ begin_document();
+
+ while (1) {
+ c = get8u(input);
+ if (c >= SET_CHAR_0 && c <= SET_CHAR_127)
+ h += outchar(c);
+ else if (c >= FNT_NUM_0 && c <= FNT_NUM_63)
+ setfont(c - FNT_NUM_0);
+ else switch(c) {
+ case SET1:
+ h += outchar(get8u(input)); break;
+ case SET2:
+ h += outchar(get16u(input)); break;
+ case SET3:
+ h += outchar(get24u(input)); break;
+ case SET4:
+ h += outchar(get32s(input)); break;
+ case SET_RULE:
+ height = get32s(input);
+ width = get32s(input);
+ outrule(height, width);
+ h += width;
+ break;
+ case PUT1:
+ (void) outchar(get8u(input)); break;
+ case PUT2:
+ (void) outchar(get16u(input)); break;
+ case PUT3:
+ (void) outchar(get24u(input)); break;
+ case PUT4:
+ (void) outchar(get32s(input)); break;
+ case PUT_RULE:
+ height = get32s(input);
+ width = get32s(input);
+ outrule(height, width);
+ break;
+ case NOP:
+ break;
+ case BOP:
+ clear_page();
+ h = v = w = x = y = z = 0;
+ sp = 0;
+ fseek(input, 44, SEEK_CUR); /* skip c0...c9 and ptr to previous page */
+ break;
+ case EOP:
+ output_page();
+ break;
+ case PUSH:
+ assert(sp < STACK_SIZE);
+ stack[sp].sh = h; stack[sp].sv = v; stack[sp].sw = w;
+ stack[sp].sx = x; stack[sp].sy = y; stack[sp].sz = z;
+ sp++;
+ break;
+ case POP:
+ assert(sp > 0);
+ sp--;
+ h = stack[sp].sh; v = stack[sp].sv; w = stack[sp].sw;
+ x = stack[sp].sx; y = stack[sp].sy; z = stack[sp].sz;
+ break;
+ case RIGHT1:
+ h += get8s(input); break;
+ case RIGHT2:
+ h += get16s(input); break;
+ case RIGHT3:
+ h += get24s(input); break;
+ case RIGHT4:
+ h += get32s(input); break;
+ case W0:
+ h += w; break;
+ case W1:
+ w = get8s(input); h += w; break;
+ case W2:
+ w = get16s(input); h += w; break;
+ case W3:
+ w = get24s(input); h += w; break;
+ case W4:
+ w = get32s(input); h += w; break;
+ case X0:
+ h += x; break;
+ case X1:
+ x = get8s(input); h += x; break;
+ case X2:
+ x = get16s(input); h += x; break;
+ case X3:
+ x = get24s(input); h += x; break;
+ case X4:
+ x = get32s(input); h += x; break;
+ case DOWN1:
+ v += get8s(input); break;
+ case DOWN2:
+ v += get16s(input); break;
+ case DOWN3:
+ v += get24s(input); break;
+ case DOWN4:
+ v += get32s(input); break;
+ case Y0:
+ v += y; break;
+ case Y1:
+ y = get8s(input); v += y; break;
+ case Y2:
+ y = get16s(input); v += y; break;
+ case Y3:
+ y = get24s(input); v += y; break;
+ case Y4:
+ y = get32s(input); v += y; break;
+ case Z0:
+ v += z; break;
+ case Z1:
+ z = get8s(input); v += z; break;
+ case Z2:
+ z = get16s(input); v += z; break;
+ case Z3:
+ z = get24s(input); v += z; break;
+ case Z4:
+ z = get32s(input); v += z; break;
+ case FNT1:
+ setfont(get8u(input)); break;
+ case FNT2:
+ setfont(get16u(input)); break;
+ case FNT3:
+ setfont(get24u(input)); break;
+ case FNT4:
+ setfont(get32s(input)); break;
+ case XXX1:
+ n = get8u(input); fseek(input, n, SEEK_CUR); break;
+ case XXX2:
+ n = get16u(input); fseek(input, n, SEEK_CUR); break;
+ case XXX3:
+ n = get24u(input); fseek(input, n, SEEK_CUR); break;
+ case XXX4:
+ n = get32s(input); fseek(input, n, SEEK_CUR); break;
+ case FNT_DEF1:
+ fontdef(input, get8u(input)); break;
+ case FNT_DEF2:
+ fontdef(input, get16u(input)); break;
+ case FNT_DEF3:
+ fontdef(input, get24u(input)); break;
+ case FNT_DEF4:
+ fontdef(input, get32s(input)); break;
+ case POST:
+ end_document(); return;
+ default:
+ assert(0);
+ }
+ }
+}
--- /dev/null
+#include <stdio.h>
+#include "io.h"
+
+int get16u(input)
+ FILE * input;
+{
+ int b1 = getc(input);
+ int b2 = getc(input);
+ return (b1 << 8) + b2;
+}
+int get16s(input)
+ FILE * input;
+{
+ int b1 = (schar) getc(input);
+ int b2 = getc(input);
+ return (b1 << 8) + b2;
+}
+int get24u(input)
+ FILE * input;
+{
+ int b1 = getc(input);
+ int b2 = getc(input);
+ int b3 = getc(input);
+ return (b1 << 16) + (b2 << 8) + b3;
+}
+int get24s(input)
+ FILE * input;
+{
+ int b1 = (schar) getc(input);
+ int b2 = getc(input);
+ int b3 = getc(input);
+ return (b1 << 16) + (b2 << 8) + b3;
+}
+int get32s(input)
+ FILE * input;
+{
+ int b1 = (schar) getc(input);
+ int b2 = getc(input);
+ int b3 = getc(input);
+ int b4 = getc(input);
+ return (b1 << 24) + (b2 << 16) + (b3 << 8) + b4;
+}
+
--- /dev/null
+#ifdef __STDC__
+typedef signed char schar;
+#else
+typedef char schar;
+#endif
+
+#define get8u(input) getc(input)
+#define get8s(input) (schar) getc(input)
+
+int get16u(), get16s(), get24u(), get24s(), get32u(), get32s();
--- /dev/null
+#include <stdio.h>
+#include "output.h"
+
+void interprete(FILE *input);
+
+char * input_name;
+
+int main(argc, argv)
+ int argc;
+ char ** argv;
+{
+ FILE * f;
+ int i;
+
+ output_device = OUTPUT_PLAIN;
+ standout_tt = 0;
+ for (i = 1; i < argc && argv[i][0] == '-'; i++) {
+ switch(argv[i][1]) {
+ case 'p':
+ output_device = OUTPUT_PRINTER; break;
+ case 'r':
+ output_device = OUTPUT_RTF; break;
+ case 's':
+ output_device = OUTPUT_STYL; break;
+ case 't':
+ standout_tt = 1; break;
+ default:
+ fprintf(stderr, "Unknown option `%s', ignored\n", argv[i]);
+ }
+ }
+ if (i >= argc) {
+ input_name = "unknown.dvi";
+ interprete(stdin);
+ } else {
+ for (/*nothing*/; i < argc; i++) {
+ f = fopen(argv[i], "r");
+ if (f == NULL) {
+ perror(argv[i]);
+ continue;
+ }
+ input_name = argv[i];
+ interprete(f);
+ fclose(f);
+ }
+ }
+ return 0;
+}
--- /dev/null
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include "output.h"
+
+void null(), print_FF(), plain_line(), printer_line();
+void begin_rtf_document(), end_rtf_document(), end_rtf_page(), rtf_line();
+void begin_styl_page(), end_styl_page(), styl_line();
+
+struct output_device {
+ void (*begin_document)();
+ void (*end_document)();
+ void (*begin_page)();
+ void (*end_page)();
+ void (*line)();
+} device[] = {
+ null, null, null, print_FF, plain_line,
+ null, null, null, print_FF, printer_line,
+ begin_rtf_document, end_rtf_document, null, end_rtf_page, rtf_line,
+ null, null, begin_styl_page, end_styl_page, styl_line
+};
+
+#define SIZEX 160
+
+struct line {
+ int ypos;
+ int len;
+ char * contents;
+ char * styles;
+ struct line * next_in_bucket;
+};
+
+#define NBUCKETS 101
+
+struct line * screenlines[NBUCKETS];
+
+int numlines;
+
+char * xmalloc(size)
+ int size;
+{
+ char * res = (char *) malloc(size);
+ if (res == NULL) {
+ fprintf(stderr, "Out of memory\n");
+ exit(2);
+ }
+ return res;
+}
+
+char * xrealloc(ptr, size)
+ char * ptr;
+ int size;
+{
+ char * res = (char *) realloc(ptr, size);
+ if (res == NULL) {
+ fprintf(stderr, "Out of memory\n");
+ exit(2);
+ }
+ return res;
+}
+
+void begin_document()
+{
+ device[output_device].begin_document();
+}
+
+void end_document()
+{
+ device[output_device].end_document();
+}
+
+void clear_page()
+{
+ int i;
+
+ for (i = 0; i < NBUCKETS; i++) screenlines[i] = NULL;
+ numlines = 0;
+}
+
+void out(x, y, c, style)
+ int x, y;
+ char c;
+ char style;
+{
+ unsigned int h;
+ struct line * line;
+
+ h = ((unsigned int) y) % NBUCKETS;
+ line = screenlines[h];
+ while (line != NULL && line->ypos != y) line = line->next_in_bucket;
+ if (line == NULL) {
+ line = (struct line *) xmalloc(sizeof(struct line));
+ line->ypos = y;
+ line->len = 80;
+ line->contents = (char *) xmalloc(line->len);
+ memset(line->contents, ' ', line->len);
+ line->styles = (char *) xmalloc(line->len);
+ memset(line->styles, PLAIN, line->len);
+ line->next_in_bucket = screenlines[h];
+ screenlines[h] = line;
+ numlines++;
+ }
+ x = x / scalex;
+ if (x < 0) return;
+ while (x >= line->len) {
+ int newlen = 2 * line->len;
+ line->contents = (char *) xrealloc(line->contents, newlen);
+ memset(line->contents + line->len, ' ', newlen - line->len);
+ line->styles = (char *) xrealloc(line->styles, newlen);
+ memset(line->styles + line->len, PLAIN, newlen - line->len);
+ line->len = newlen;
+ }
+ line->contents[x] = c;
+ line->styles[x] = style;
+}
+
+static void free_bucket(l)
+ struct line * l;
+{
+ if (l != NULL) {
+ free(l->contents);
+ free(l->styles);
+ free_bucket(l->next_in_bucket);
+ free(l);
+ }
+}
+
+static void free_buckets()
+{
+ int i;
+ for (i = 0; i < NBUCKETS; i++) free_bucket(screenlines[i]);
+}
+
+static int compare_lines(l1, l2)
+ struct line ** l1, ** l2;
+{
+ return (**l1).ypos - (**l2).ypos;
+}
+
+void output_page()
+{
+ struct line ** lines;
+ struct line * l;
+ int i, j, k, y;
+ char * p, * q, * style_p, * style_q, * s;
+
+ device[output_device].begin_page();
+
+ /* First, sort the lines by y coordinate */
+ lines = (struct line **) malloc(numlines * sizeof(struct line *));
+ if (lines == NULL) {
+ printf("*** Out of memory ***\n\014");
+ free_buckets();
+ return;
+ }
+ j = 0;
+ for (i = 0; i < NBUCKETS; i++)
+ for (l = screenlines[i]; l != NULL; l = l->next_in_bucket)
+ lines[j++] = l;
+ qsort(lines, numlines, sizeof(struct line *), compare_lines);
+
+ /* Output the lines */
+
+ y = 0;
+ for (i = 0; i < numlines; i++) {
+ /* Emit blank lines to reach the current line ypos */
+ while (lines[i]->ypos - y >= 3 * scaley / 2) {
+ device[output_device].line(NULL, NULL, 0);
+ y += scaley;
+ }
+ /* If next line is close to current line, attempt to merge them */
+ while (i + 1 < numlines &&
+ lines[i+1]->ypos - lines[i]->ypos < scaley) {
+ p = lines[i]->contents;
+ q = lines[i+1]->contents;
+ style_p = lines[i]->styles;
+ style_q = lines[i+1]->styles;
+ for (j = lines[i]->len; j < lines[i+1]->len; j++)
+ if (q[j] != ' ') goto cannot_merge;
+ for (j = lines[i+1]->len; j < lines[i]->len; j++)
+ if (p[j] != ' ') goto cannot_merge;
+ k = lines[i]->len;
+ if (k > lines[i+1]->len) k = lines[i+1]->len;
+ for (j = 0; j < k; j++)
+ if (p[j] != ' ' && q[j] != ' ') goto cannot_merge;
+ /* Seems OK, do the merging */
+ for (j = 0; j < k; j++)
+ if (p[j] != ' ') {
+ q[j] = p[j];
+ style_q[j] = style_p[j];
+ }
+ /* Now consider next line */
+ i++;
+ }
+ cannot_merge:
+ /* Now print the current line */
+ p = lines[i]->contents;
+ q = p + lines[i]->len;
+ while (q >= p && *--q == ' ') /*nothing*/;
+ device[output_device].line(p, lines[i]->styles, q-p+1);
+ /* Go on with next line */
+ y = lines[i]->ypos;
+ }
+
+ device[output_device].end_page();
+ free(lines);
+ free_buckets();
+}
+
--- /dev/null
+#define SCALEX 404685
+#define SCALEY 786432
+
+int scalex;
+int scaley;
+
+#define PLAIN 0
+#define ITALICS 1
+#define BOLD 2
+#define MONOSPACED 3
+
+void begin_document();
+void end_document();
+void clear_page();
+void output_page();
+void out();
+
+int output_device;
+int standout_tt;
+
+#define OUTPUT_PLAIN 0
+#define OUTPUT_PRINTER 1
+#define OUTPUT_RTF 2
+#define OUTPUT_STYL 3
--- /dev/null
+#include <stdio.h>
+#include "output.h"
+
+/* Low-level output functions */
+
+void null()
+{
+}
+
+void print_FF()
+{
+ putchar('\014');
+}
+
+void plain_line(txt, style, len)
+ char * txt, * style;
+ int len;
+{
+ fwrite(txt, 1, len, stdout);
+ putchar('\n');
+}
+
+void printer_line(txt, style, len)
+ char * txt, * style;
+ int len;
+{
+ for (/*nothing*/; len > 0; len--, txt++, style++) {
+ putchar(*txt);
+ switch(*style) {
+ case ITALICS:
+ putchar('\b'); putchar('_'); break;
+ case BOLD:
+ putchar('\b'); putchar(*txt); break;
+ case MONOSPACED:
+ if (standout_tt) { putchar('\b'); putchar(*txt); }
+ break;
+ }
+ }
+ putchar('\n');
+}
+
--- /dev/null
+#include <stdio.h>
+#include "output.h"
+
+/* Rich Text Format */
+
+void begin_rtf_document()
+{
+ printf("{\\rtf1\\ansi\\deff0\n");
+ printf("{\\fonttbl{\\f0\\fmodern Courier;}}\n");
+ printf("\\f0\\fs20\n");
+}
+
+void end_rtf_document()
+{
+ printf("}\n");
+}
+
+void end_rtf_page()
+{
+ printf("\\page\n");
+}
+
+void rtf_line(txt, style, len)
+ char * txt, * style;
+ int len;
+{
+ int currstyle;
+
+ for (currstyle = PLAIN; len > 0; len--, txt++, style++) {
+ if (*txt != ' ') {
+ switch(*style) {
+ case PLAIN:
+ if (currstyle != PLAIN) {
+ putchar('}');
+ currstyle = PLAIN;
+ }
+ break;
+ case ITALICS:
+ if (currstyle != ITALICS) {
+ if (currstyle != PLAIN) putchar('}');
+ printf("{\\i ");
+ currstyle = ITALICS;
+ }
+ break;
+ case BOLD:
+ if (currstyle != BOLD) {
+ if (currstyle != PLAIN) putchar('}');
+ printf("{\\b ");
+ currstyle = BOLD;
+ }
+ break;
+ case MONOSPACED:
+ if (standout_tt) {
+ if (currstyle != BOLD) {
+ if (currstyle != PLAIN) putchar('}');
+ printf("{\\b ");
+ currstyle = BOLD;
+ }
+ } else {
+ if (currstyle != PLAIN) {
+ putchar('}');
+ currstyle = PLAIN;
+ }
+ }
+ break;
+ }
+ }
+ switch(*txt) {
+ case '\\':
+ case '{':
+ case '}':
+ putchar('\\'); putchar(*txt); break;
+ default:
+ putchar(*txt); break;
+ }
+ }
+ if (currstyle != PLAIN) putchar('}');
+ printf("\\par\n");
+}
+
--- /dev/null
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include "output.h"
+
+/* Macintosh STYL tables */
+
+extern char * input_name;
+
+static FILE * text;
+static FILE * styl;
+static int partnum = 0;
+static int currstyle;
+static int currstart;
+static int currpos;
+
+static void output_current_style()
+{
+ int style_code;
+
+ switch(currstyle) {
+ case PLAIN:
+ style_code = 0; break;
+ case ITALICS:
+ style_code = 2; break;
+ case BOLD:
+ style_code = 1 + 32; break; /* bold condensed */
+ case MONOSPACED:
+ style_code = standout_tt ? 1 + 32 : 0; break;
+ }
+ fprintf(styl, "%d %d Monaco %d 9 0 0 0\n", currstart, currpos, style_code);
+}
+
+
+static void output_style_change(newstyle)
+ int newstyle;
+{
+ if (!standout_tt && (newstyle == PLAIN && currstyle == MONOSPACED ||
+ newstyle == MONOSPACED && currstyle == PLAIN)) {
+ currstyle = newstyle;
+ return;
+ }
+ output_current_style();
+ currstyle = newstyle;
+ currstart = currpos;
+}
+
+void begin_styl_page()
+{
+ char name[1024], buffer[1024];
+ int n;
+
+ strcpy(name, input_name);
+ n = strlen(name);
+ if (n >= 4 && strcmp(name + n - 4, ".dvi") == 0) name[n - 4] = 0;
+ partnum++;
+ sprintf(buffer, "%s.%03d.txt", name, partnum);
+ text = fopen(buffer, "w");
+ if (text == NULL) { perror(buffer); exit(2); }
+ sprintf(buffer, "%s.%03d.stl", name, partnum);
+ styl = fopen(buffer, "w");
+ if (styl == NULL) { perror(buffer); exit(2); }
+ currstyle = PLAIN;
+ currstart = 0;
+ currpos = 0;
+}
+
+void end_styl_page()
+{
+ output_current_style();
+ fclose(text);
+ fclose(styl);
+}
+
+void styl_line(txt, style, len)
+ char * txt, * style;
+ int len;
+{
+ for (/*nothing*/; len > 0; len--, txt++, style++, currpos++) {
+ putc(*txt, text);
+ if (*txt != ' ' && *style != currstyle) {
+ output_style_change(*style);
+ }
+ }
+ putc('\n', text);
+ currpos++;
+}
+
+
+
--- /dev/null
+#!/bin/sh
+
+# usage: fix_index.sh <file>.idx
+
+# This script works around a hyperref bug: hyperref does not handle
+# quotes in \index arguments properly.
+#
+# Symptom:
+# When \index{-pipe-pipe@\verb`("|"|)`} appears in your .tex, the hyperref
+# package mangles it and produces this line in your .idx:
+# \indexentry{(-pipe-pipe)@\verb`("|hyperindexformat{\"}}{292}
+# instead of the expected:
+# \indexentry{(-pipe-pipe)@\verb`("|"|)`|hyperpage}{292}
+#
+# This is because it fails to handle quoted characters correctly.
+#
+# The workaround:
+# Look for the buggy line in the given .idx file and change it.
+
+# Note: this bug will happen every time you have a | (pipe) character
+# in an index entry (properly quoted with a " (double-quote) before it).
+# We fix only the one case that appears in the OCaml documentation.
+# We do not attempt a general solution because hyperref erases part
+# of the argument, so we cannot recover the correct string from its
+# output.
+
+# Note 2013-06-19:
+# The above was for the || operator in the stdlib's Pervasives module.
+# Now we have the same problem with the |> operator that was added
+# to the same module in commit 13739, hence the second special case.
+
+usage(){
+ echo "usage: fix_index.sh <file>.idx" >&2
+ exit 2
+}
+
+case $# in
+ 1) ;;
+ *) usage;;
+esac
+
+ed "$1" <<'EOF'
+/-pipe-pipe/s/verb`("|hyperindexformat{\\"}/verb`("|"|)`|hyperpage/
+/-pipe-gt/s/verb`("|hyperindexformat{\\>)`}/verb`("|>)`|hyperpage/
+w
+q
+EOF
+
+case $? in
+ 0) echo "fix_index.sh: fixed $1 successfully.";;
+ *) echo "fix_index.sh: some error occurred."; exit 0;;
+esac
--- /dev/null
+#!/usr/bin/perl
+
+$sep = "\246";
+
+$html = 0;
+if ($ARGV[0] eq "-html") {
+ $html = 1;
+ shift;
+}
+
+# Skip initial junk
+
+while(($_ = <>) && ! m/^\(\* Module \[(.*)\]:/) { }
+m/^\(\* Module \[(.*)\]:/;
+$modname = $1;
+chop;
+s/^\(\* *//;
+s/ *\*\) *$//;
+s/\[/{\\tt /g;
+s/\]/}/g;
+print "\\section{$_}\n\n";
+$label = $modname; $label =~ s/[^A-Za-z0-9]//g;
+print "\\label{s:$label}\n";
+print "\\index{$modname (module)@\\verb~$modname~ (module)}%\n\n";
+s/{\\tt //g;
+s/}//g;
+s/_//g;
+print "\\pdfsection{$_}\n\n";
+
+$incomment = 0;
+$inverbatim = 0;
+
+line:
+while(<>) {
+ chop;
+ last line if /^\s*\(\*--/;
+ if (s/^\(\*- //) {
+ s/ *\*\)$//;
+ }
+ if (m/^\s*\(\*\*\*\s*(.*)\*\)\s*$/) {
+ if ($inverbatim) {
+ do end_verbatim();
+ }
+ print "\\subsection*{", $1, "}\n";
+ next line;
+ }
+ if (m/^\s*\(\*\*\s*(.*)\*\)\s*$/) {
+ if ($inverbatim) {
+ do end_verbatim();
+ }
+ print "\\subsubsection*{", $1, "}\n";
+ next line;
+ }
+ if (s/^\s*\(\*//) {
+ if ($inverbatim) {
+ do end_verbatim();
+ }
+ print "\\begin{comment}\n";
+ $incomment = 1;
+ }
+ if ($incomment) {
+ $endcomment = s/\*\)\s*$//;
+ if (m/^\s*\[\s*$/) {
+ print "\\begin{restoreindent}\n" unless $html;
+ print "\\begin{verbatim}\n";
+ while (($_ = <>) && ! m/^\s*\]\s*$/) {
+ print $_;
+ }
+ print "\\end{verbatim}\n";
+ print "\\end{restoreindent}\n" unless $html;
+ } else {
+ if (s/^-//) {
+ print "\\\\";
+ print "[\\smallskipamount]" unless $html;
+ }
+ s/^\s*//;
+ $count = 0;
+ foreach $part (split(/(\\?[\[\]])/, $_)) {
+ if ($part eq "[") {
+ print ($count == 0 ? "\\verb$sep" : "[");
+ $count++;
+ } elsif ($part eq "]") {
+ $count--;
+ print ($count == 0 ? "$sep" : "]");
+ } elsif ($part =~ m/^\\([\[\]])$/) {
+ print $1;
+ } else {
+ print $part;
+ }
+ }
+ }
+ if ($endcomment) {
+ print "\n\\end{comment}";
+ $incomment = 0;
+ $inverbatim = 0;
+ }
+ } else {
+ next line if /^$/;
+ if (! $inverbatim) {
+ print "\\begin{verbatim}\n";
+ $inverbatim = 1;
+ }
+ s/^external /val /;
+ s/ = ("[^"]*"\s*)+$//;
+ next line if /^\s*$/;
+ s/^val \( ([^ )]+) \)/val (\1)/;
+ {
+ do indexentry($1, " (operator)"), last
+ if (m/^val \(([^)]*)\)/);
+ do indexentry($1, ""), last
+ if (m/^val ([a-zA-Z0-9_']*)/);
+ do indexentry($1, " (type)"), last
+ if (m/^type\s.*([a-zA-Z0-9_']*)\s*=/);
+ do indexentry($1, " (exception)"), last
+ if (m/^exception ([a-zA-Z0-9_']*)/);
+ do indexentry($1, " (module type)"), last
+ if (m/^module type ([a-zA-Z0-9_']*)/);
+ do indexentry($1, " (functor)"), last
+ if (m/^module ([a-zA-Z0-9_']*)\s*\(/);
+ do indexentry($1, " (module)"), last
+ if (m/^module ([a-zA-Z0-9_']*)/);
+ }
+ print $_;
+ }
+ print "\n";
+}
+do end_verbatim() if $inverbatim;
+print "\\end{comment}\n" if $incomment;
+
+sub indexentry {
+ local ($_, $comment) = @_;
+ return if m/^$/ || m/^[a-zA-Z]$/;
+ s/([@|!])/"$1/g;
+ if (! m|`|) {
+ $s = "`";
+ } elsif (! m|~|) {
+ $s = "~";
+ } elsif (! m/\|/) {
+ $s = "|";
+ } else {
+ die("Can't find quote character for $_");
+ }
+ push (@index, "\\index{$_$comment@\\verb$s$_$s$comment}");
+}
+
+sub end_verbatim {
+ print "\\end{verbatim}\n";
+ foreach $idx (@index) {
+ print $idx, "%\n";
+ }
+ undef(@index);
+ $inverbatim = 0;
+}
--- /dev/null
+#!/usr/local/bin/perl
+# Split an HTML file into smaller nodes.
+# Split at <H1> headers and also at some <H2> headers.
+
+$h0 = "H0";
+$h1 = "H1";
+$h2 = "H2";
+
+# Parse options
+
+option:
+while(1) {
+ $_ = $ARGV[0];
+ if (/^-([0-9]+)$/) {
+ $split2[$1] = 1;
+ }
+ elsif (/^-article/) {
+ $h0 = "H1";
+ $h1 = "H2";
+ $h2 = "H3";
+ }
+ else {
+ last option;
+ }
+ shift(@ARGV);
+}
+
+$infile = $ARGV[0];
+
+# Find URL's for the links
+
+$level0 = 0;
+$level1 = 0;
+$uselabel = 1;
+open(INPUT, $infile);
+while(<INPUT>) {
+ if (m|^<$h0>(.*)</$h0>|o) {
+ $level0++;
+ $currfile = "node" . ($level1 + 1) . ".html";
+ $lblnum = $level0;
+ $uselabel = 0;
+ }
+ if (m|^<$h1>(.*)</$h1>|o) {
+ $level1++;
+ $level2 = 0;
+ $currfile = "node$level1.html";
+ $lblnum = $level1;
+ $uselabel = 1;
+ }
+ if (m|^<$h2>(.*)</$h2>|o) {
+ $level2++;
+ if ($split2[$level1]) { $currfile = "node$level1.$level2.html"; }
+ $lblnum = "$level1.$level2";
+ }
+ s|<A NAME="([^"]*)"></A>|do set_url($1)|ige;
+}
+
+sub set_url {
+ local ($lbl) = @_;
+ if ($uselabel) {
+ $url{$lbl} = "$currfile#$lbl";
+ } else {
+ $url{$lbl} = $currfile;
+ }
+ $label{$lbl} = $lblnum;
+}
+
+# Cut the file
+
+$level1 = 0;
+open(INPUT, $infile);
+while(<INPUT>) {
+ if (m|^<$h0>(.*)</$h0>|o) {
+ if ($level2 > 0) { print FILE1 "</UL>\n"; }
+ select(STDOUT);
+ if ($level1 >= 1) { print "</UL>"; }
+ print "<$h2>$1</$h2>\n";
+ if ($level1 >= 1) { print "<UL>"; }
+ next;
+ }
+ if (m|^<$h1>(.*)</$h1>|o) {
+ if ($level2 > 0) { print FILE1 "</UL>\n"; }
+ $level1++;
+ $level2 = 0;
+ select(STDOUT);
+ if ($level1 == 1) { print "<HR><BR><UL>\n"; }
+ print "<LI><A HREF=\"node$level1.html\">$1</A>\n";
+ open(FILE1, "> node$level1.html");
+ select(FILE1);
+ &print_title($1);
+ }
+ if ($split2[$level1] && m|^<$h2>(.*)</$h2>|o) {
+ $level2++;
+ select(FILE1);
+ if ($level2 == 1) { print "<HR><BR><UL>\n"; }
+ print "<LI><A HREF=\"node$level1.$level2.html\">$1</A>\n";
+ open(FILE2, "> node$level1.$level2.html");
+ select(FILE2);
+ &print_title($1);
+ }
+ s|<A HREF="#([^"]*)">X</A>|'<A HREF="' . $url{$1} . '">' . $label{$1} . '</A>'|ige;
+ print $_;
+}
+select(STDOUT);
+if ($level1 >= 1) { print "</UL>\n"; }
+
+sub print_title {
+ local ($title) = @_;
+ $title =~ s|<[a-zA-Z/]+>||g;
+ print "<TITLE>$title</TITLE>\n";
+}
--- /dev/null
+#include <stdio.h>
+#include <ctype.h>
+
+#define LINE_LENGTH 1024
+
+char line[LINE_LENGTH];
+
+int isprefix(s, pref)
+ char * s;
+ char * pref;
+{
+ while (1) {
+ if (*pref == 0) return 1;
+ if (*s == 0) return 0;
+ if (*s != *pref) return 0;
+ s++;
+ pref++;
+ }
+}
+
+int main(argc, argv)
+ int argc;
+ char * argv [];
+{
+ unsigned char * p;
+ int c;
+ int inquote;
+ int inverb;
+ int inverbatim;
+
+ inverbatim = 0;
+ inquote = 0;
+
+ while(fgets(line, LINE_LENGTH, stdin) != NULL) {
+ if (inverbatim) {
+ fputs(line, stdout);
+ if (isprefix(line, "\\end{verbatim")
+ || isprefix(line, "\\end{alltt}")) inverbatim = 0;
+ continue;
+ }
+ if (isprefix(line, "\\begin{verbatim")
+ || isprefix(line, "\\begin{alltt}")) {
+ fputs(line, stdout);
+ inverbatim = 1;
+ continue;
+ }
+ inverb = 0;
+ for (p = (unsigned char *) line; *p != 0; p++) {
+ c = *p;
+ if (inverb) {
+ if (c == inverb) inverb = 0;
+ putchar(c);
+ continue;
+ }
+ switch(c) {
+ case '"':
+ if (inquote) {
+ fputs("\001", stdout);
+ inquote = 0;
+ } else {
+ fputs("\\verb\001", stdout);
+ inquote = 1;
+ }
+ break;
+ case '\\':
+ if (isprefix(p, "\\verb") && p[5] != 0 && !isalpha(p[5])) {
+ inverb = p[5];
+ p = p + 5;
+ fputs("\\verb", stdout);
+ putchar(inverb);
+ } else if (inquote) {
+ if (p[1] == '"' || p[1] == '\\') {
+ c = p[1];
+ p++;
+ }
+ putchar(c);
+ } else {
+ putchar('\\');
+ }
+ break;
+ default:
+ putchar(c);
+ }
+ }
+ }
+ return 0;
+}
--- /dev/null
+#!/usr/local/bin/perl
+
+while (<>) {
+ if (m|^<tbl[> ]|) {
+ while (! m|</tbl>$|) { $_ .= <>; }
+ s/\n//g;
+ print "<pre>\n";
+ do format_table($_);
+ print "</pre>\n";
+ } else {
+ print $_;
+ }
+}
+
+sub format_table {
+# On input, $_ contains:
+# <tbl [border]><th>Header 1<th>Header2<th>...<th>Header M<tr>
+# <td>Data11<td>Data12<td>...<td>Data1M<tr>
+# ...
+# <td>DataN1<td>DataN2<td>...<td>DataNM<tr>
+# </tbl>
+
+# Extract the entries and compute the number of lines and columns
+
+ $numlines = 0;
+ $numcols = 0;
+ $border = 0;
+ $header = 0;
+ $x = 0;
+ $y = 0;
+ foreach $_ (split(/(<tbl[ a-zA-Z]*>|<th>|<td>|<tr>|<\/tbl>)/, $_)) {
+ if (/^$/) { next; }
+ elsif (/<tbl border>/) { $border = 1; }
+ elsif (/<tr>/i) {
+ if ($x > $numcols) { $numcols = $x; }
+ $x = 0;
+ $y++;
+ }
+ elsif (/<th>/) { $header = 1; }
+ elsif (!/(<tbl[ a-zA-Z]*>|<th>|<td>|<tr>|<\/tbl>)/) {
+ s|</?[a-zA-Z]*>||g; # Remove embedded tags
+ s/^\s*//; # and initial blanks
+ s/\s*$//; # and final blanks
+ s/\s\s\s*/ /g; # and extra blanks
+ s/</</g; # Unescape HTML specials
+ s/>/>/g;
+ s/&/&/g;
+ $entry{$x, $y} = $_;
+ $x++;
+ }
+ }
+ $numlines = $y;
+
+# Compute the max width of each column
+
+ $totalwidth = 0;
+
+ for ($x = 0; $x < $numcols; $x++) {
+ $max = 0;
+ for ($y = 0; $y < $numlines; $y++) {
+ $len = length($entry{$x, $y});
+ if ($len > $max) { $max = $len; }
+ }
+ $width[$x] = $max;
+ $totalwidth += $max;
+ }
+
+# If it does not fit in one line, turn wide fields into multi-line fields
+
+ if ($totalwidth >= 65) {
+ $totalwidth = 0;
+ $maxwidth = 65 / $numcols;
+ for ($x = 0; $x < $numcols; $x++) {
+ if ($width[$x] > $maxwidth) {
+ if ($x < $numcols - 1) {
+ $width[$x] = $maxwidth;
+ } else {
+ $width[$x] = 70 - $totalwidth;
+ }
+ }
+ $totalwidth += $width[$x];
+ }
+ }
+
+# Compute the separators
+
+ if ($border) {
+ $horsep = '+-';
+ for ($x = 0; $x < $numcols; $x++) {
+ if ($x > 0) { $horsep .= '-+-'; }
+ $horsep .= '-' x $width[$x];
+ }
+ $horsep .= '-+';
+ $verleft = '| ';
+ $versep = ' | ';
+ $verright = ' |';
+ } else {
+ $horsep = '';
+ $verleft = ' ';
+ $versep = ' ';
+ $verright = ' ';
+ }
+
+# Print the table
+ print $horsep, "\n";
+ for ($y = 0; $y < $numlines; $y++) {
+ do {
+ $overflow = 0;
+ print $verleft;
+ for ($x = 0; $x < $numcols; $x++) {
+ if ($x > 0) { print $versep; }
+ $_ = $entry{$x, $y};
+ if (length($_) > $width[$x]) {
+ $pos = rindex($_, ' ', $width[$x]);
+ if ($pos < 0) { $pos = $width[$x]; } else { $pos++; }
+ $entry{$x, $y} = substr($_, $pos);
+ $_ = substr($_, 0, $pos - 1);
+ $overflow = 1;
+ } else {
+ $entry{$x, $y} = '';
+ }
+ $len = length($_);
+ s/&/&/g;
+ s/</</g;
+ s/>/>/g;
+ print $_, ' ' x ($width[$x] - $len);
+ }
+ print $verright, "\n";
+ } while($overflow);
+ if ($header && $y == 0) { print $horsep, "\n"; }
+ }
+ print $horsep, "\n";
+}
+
--- /dev/null
+#!/usr/local/bin/perl
+# Insert Next/Previous/Contents buttons in a set of pages.
+
+@pages = sort fragmentorder @ARGV;
+
+sub fragmentorder {
+ $a =~ /^node([0-9]+)/; $na = $1;
+ if ($a =~ /^node[0-9]+\.([0-9]+)\.html/) { $fa = $1; } else { $fa = 0; }
+ $b =~ /^node([0-9]+)/; $nb = $1;
+ if ($b =~ /^node[0-9]+\.([0-9]+)\.html/) { $fb = $1; } else { $fb = 0; }
+ return (($na <=> $nb) || ($fa <=> $fb));
+}
+
+for ($i = 0; $i <= $#pages; $i++) {
+ open(SRC, $pages[$i]);
+ open(DST, "> newpage.html");
+ select(DST);
+ $_ = <SRC>; # Title line
+ print "<HEAD>\n";
+ print $_;
+ do links();
+ print "</HEAD>\n";
+ print "<BODY>\n";
+ do buttons();
+ print "<HR>\n";
+ $numlines = 0;
+ while (<SRC>) {
+ $numlines++;
+ print $_;
+ }
+ if ($numlines >= 40) {
+ print "<HR>\n";
+ do buttons();
+ }
+ close(SRC);
+ close(DST);
+ rename("newpage.html", $pages[$i]);
+}
+
+sub links {
+ if ($i > 0) {
+ print '<LINK REL="Prev" HREF="', $pages[$i-1], "\">\n";
+ }
+ if ($i < $#pages) {
+ print '<LINK REL="Next" HREF="', $pages[$i+1], "\">\n";
+ }
+ print "<LINK REL=\"ToC\" HREF=\"index.html\">\n";
+}
+
+sub buttons {
+ if ($i > 0) {
+ print '<A HREF="', $pages[$i-1], '"><IMG SRC="previous_motif.gif" ALT="Previous"></A>', "\n";
+ }
+ if ($i < $#pages) {
+ print '<A HREF="', $pages[$i+1], '"><IMG SRC="next_motif.gif" ALT="Next"></A>', "\n";
+ }
+ print '<A HREF="index.html"><IMG SRC="contents_motif.gif" ALT="Contents"></A>', "\n";
+}
--- /dev/null
+{
+open Lexing;;
+
+let need_space =
+ ref false;;
+
+let addspace () =
+ if !need_space then begin print_char ' '; need_space := false end;;
+}
+
+rule main = parse
+ "\\begin{syntax}" {
+ print_string "\\begin{rawhtml}\n<PRE>\n";
+ need_space := false;
+ syntax lexbuf;
+ print_string "</PRE>\n\\end{rawhtml}\n";
+ main lexbuf }
+ | "\\@" {
+ print_string "@";
+ main lexbuf }
+ | "@" {
+ print_string "%\n\\begin{rawhtml}";
+ need_space := false;
+ syntax lexbuf;
+ print_string "\\end{rawhtml}%\n";
+ main lexbuf }
+ | _ {
+ print_char (lexeme_char lexbuf 0); main lexbuf }
+ | eof {
+ () }
+
+and syntax = parse
+ "\\end{syntax}" { () }
+ | "@" { () }
+ | '\'' {
+ addspace();
+ print_string "<font color=\"blue\"><code>";
+ inquote lexbuf;
+ print_string "</code></font>";
+ need_space := true;
+ syntax lexbuf }
+ | '\"' {
+ addspace();
+ print_string "<font color=\"blue\"><code>";
+ indoublequote lexbuf;
+ print_string "</code></font>";
+ need_space := true;
+ syntax lexbuf }
+ | ['a'-'z'] ['a'-'z' '0'-'9' '-'] * {
+ addspace();
+ print_string "<i>";
+ print_string (lexeme lexbuf);
+ print_string "</i>";
+ need_space := true;
+ syntax lexbuf }
+ | '\\' ['a'-'z''A'-'Z'] + {
+ begin match lexeme lexbuf with
+ "\\ldots" -> print_string "..."; need_space := false
+ | s -> Printf.eprintf "Warning: %s ignored.\n" s
+ end;
+ syntax lexbuf }
+ | '_' _ {
+ print_string "<SUB>";
+ print_char(lexeme_char lexbuf 1);
+ print_string "</SUB>";
+ syntax lexbuf }
+ | '^' _ {
+ print_string "<SUP>";
+ print_char(lexeme_char lexbuf 1);
+ print_string "</SUP>";
+ syntax lexbuf }
+ | ":" {
+ print_string ":\n ";
+ need_space := false;
+ syntax lexbuf }
+ | "|" {
+ print_string "\n | ";
+ need_space := false;
+ syntax lexbuf }
+ | ";" {
+ print_string "\n\n";
+ need_space := false;
+ syntax lexbuf }
+ | [ '{' '[' '('] {
+ addspace(); print_string (lexeme lexbuf); syntax lexbuf }
+ | [ '}' ']' ')'] {
+ print_string (lexeme lexbuf); syntax lexbuf }
+ | "{{" {
+ addspace(); print_string "{"; syntax lexbuf }
+ | "}}" {
+ print_string "}+"; syntax lexbuf }
+ | "||" {
+ print_string " | "; need_space := false; syntax lexbuf }
+ | [ ' ' '\n' '\t' '~'] {
+ syntax lexbuf }
+ | [ ',' ] {
+ print_char(lexeme_char lexbuf 0); syntax lexbuf }
+ | _ {
+ Printf.eprintf "Warning: %s ignored at char %d.\n"
+ (lexeme lexbuf) (lexeme_start lexbuf);
+ syntax lexbuf }
+
+and inquote = parse
+ '\'' { () }
+ | '&' { print_string "&"; inquote lexbuf }
+ | '<' { print_string "<"; inquote lexbuf }
+ | '>' { print_string ">"; inquote lexbuf }
+ | _ { print_char (lexeme_char lexbuf 0); inquote lexbuf }
+
+and indoublequote = parse
+ '"' { () }
+ | '&' { print_string "&"; indoublequote lexbuf }
+ | '<' { print_string "<"; indoublequote lexbuf }
+ | '>' { print_string ">"; indoublequote lexbuf }
+ | _ { print_char (lexeme_char lexbuf 0); indoublequote lexbuf }
+
+
--- /dev/null
+type action =
+ Print of string
+ | Print_arg
+ | Skip_arg;;
+
+let cmdtable = (Hashtbl.create 19 : (string, action list) Hashtbl.t);;
+
+let def_macro name action =
+ Hashtbl.add cmdtable name action;;
+
+let find_macro name =
+ try
+ Hashtbl.find cmdtable name
+ with Not_found ->
+ prerr_string "Unknown macro: "; prerr_endline name; [];;
+
+(* General LaTeX macros *)
+
+def_macro "\\part"
+ [Print "<H0>"; Print_arg; Print "</H0>\n"];
+def_macro "\\chapter"
+ [Print "<H1>"; Print_arg; Print "</H1>\n"];
+def_macro "\\chapter*"
+ [Print "<H1>"; Print_arg; Print "</H1>\n"];
+def_macro "\\section"
+ [Print "<H2>"; Print_arg; Print "</H2>\n"];
+def_macro "\\section*"
+ [Print "<H2>"; Print_arg; Print "</H2>\n"];
+def_macro "\\subsection"
+ [Print "<H3>"; Print_arg; Print "</H3>\n"];
+def_macro "\\subsection*"
+ [Print "<H3>"; Print_arg; Print "</H3>\n"];
+def_macro "\\subsubsection"
+ [Print "<H4>"; Print_arg; Print "</H4>\n"];
+def_macro "\\subsubsection*"
+ [Print "<H4>"; Print_arg; Print "</H4>\n"];
+def_macro "\\paragraph"
+ [Print "<B>"; Print_arg; Print "</B> \n"];
+def_macro "\\begin{alltt}" [Print "<pre>"];
+def_macro "\\end{alltt}" [Print "</pre>"];
+def_macro "\\begin{itemize}" [Print "<p><ul>"];
+def_macro "\\end{itemize}" [Print "</ul>"];
+def_macro "\\begin{enumerate}" [Print "<p><ol>"];
+def_macro "\\end{enumerate}" [Print "</ol>"];
+def_macro "\\begin{description}" [Print "<p><dl>"];
+def_macro "\\end{description}" [Print "</dl>"];
+def_macro "\\begin{center}" [Print "<blockquote>"];
+def_macro "\\end{center}" [Print "</blockquote>"];
+def_macro "\\begin{quote}" [Print "<blockquote>"];
+def_macro "\\end{quote}" [Print "</blockquote>"];
+def_macro "\\begin{quotation}" [Print "<blockquote>"];
+def_macro "\\end{quotation}" [Print "</blockquote>"];
+def_macro "\\smallskip" [];
+def_macro "\\medskip" [];
+def_macro "\\bigskip" [];
+def_macro "\\markboth" [Skip_arg; Skip_arg];
+def_macro "\\ldots" [Print "..."];
+def_macro "\\ " [Print " "];
+def_macro "\\{" [Print "{"];
+def_macro "\\}" [Print "}"];
+def_macro "\\%" [Print "%"];
+def_macro "\\$" [Print "$"];
+def_macro "\\#" [Print "#"];
+def_macro "\\/" [];
+def_macro "\\newpage" [];
+def_macro "\\label" [Print "<A name=\""; Print_arg; Print "\"></A>"];
+def_macro "\\ref" [Print "<A href=\"#"; Print_arg; Print "\">X</A>"];
+def_macro "\\pageref" [Print "<A href=\"#"; Print_arg; Print "\">X</A>"];
+def_macro "\\index" [Skip_arg];
+def_macro "\\oe" [Print "oe"];
+def_macro "\\&" [Print "&"];
+def_macro "\\_" [Print "_"];
+def_macro "\\leq" [Print "<="];
+def_macro "\\geq" [Print ">="];
+def_macro "\\hbox" [Print_arg];
+def_macro "\\copyright" [Print "\169"];
+def_macro "\\noindent" [];
+def_macro "\\begin{flushleft}" [Print "<blockquote>"];
+def_macro "\\end{flushleft}" [Print "</blockquote>"];
+def_macro "\\\\" [Print "<br>"];
+def_macro "\\begin{htmlonly}" [];
+def_macro "\\end{htmlonly}" [];
+();;
+
+(* Macros specific to the Caml manual *)
+
+def_macro "\\begin{options}" [Print "<p><dl>"];
+def_macro "\\end{options}" [Print "</dl>"];
+def_macro "\\var" [Print "<i>"; Print_arg; Print "</i>"];
+def_macro "\\optvar" [Print "[<i>"; Print_arg; Print "</i>]"];
+def_macro "\\nth" [Print "<i>"; Print_arg;
+ Print "</i><sub>"; Print_arg; Print "</sub>"];
+def_macro "\\nmth" [Print "<i>"; Print_arg;
+ Print "</i><sub>"; Print_arg;
+ Print "</sub><sup>"; Print_arg;
+ Print "</sup>"];
+def_macro "\\begin{unix}" [Print "<dl><dt><b>Unix:</b><dd>"];
+def_macro "\\end{unix}" [Print "</dl>"];
+def_macro "\\begin{macos}" [Print "<dl><dt><b>MacOS:</b><dd>"];
+def_macro "\\end{macos}" [Print "</dl>"];
+def_macro "\\begin{windows}" [Print "<dl><dt><b>Windows:</b><dd>"];
+def_macro "\\end{windows}" [Print "</dl>"];
+def_macro "\\begin{requirements}" [Print "<dl><dt><b>Requirements:</b><dd>"];
+def_macro "\\end{requirements}" [Print "</dl>"];
+def_macro "\\begin{troubleshooting}" [Print "<dl><dt><b>Troubleshooting:</b><dd>"];
+def_macro "\\end{troubleshooting}" [Print "</dl>"];
+def_macro "\\begin{installation}" [Print "<dl><dt><b>Installation:</b><dd>"];
+def_macro "\\end{installation}" [Print "</dl>"];
+def_macro "\\index" [Skip_arg];
+def_macro "\\ikwd" [Skip_arg];
+def_macro "\\th" [Print "-th"];
+def_macro "\\begin{library}" [];
+def_macro "\\end{library}" [];
+def_macro "\\begin{comment}" [Print "<dl><dd>"];
+def_macro "\\end{comment}" [Print "</dl>"];
+def_macro "\\begin{tableau}"
+ [Skip_arg;
+ Print "<table border>\n<tr><th>";
+ Print_arg;
+ Print "</th><th>";
+ Print_arg;
+ Print "</th></tr>"];
+def_macro "\\entree"
+ [Print "<tr><td>"; Print_arg;
+ Print "</td><td>"; Print_arg; Print "</td></tr>"];
+def_macro "\\end{tableau}" [Print "</table>"];
+def_macro "\\begin{gcrule}" [Print "<dl><dt><b>Rule:</b><dd>"];
+def_macro "\\end{gcrule}" [Print "</dl>"];
+def_macro "\\begin{tableauoperateurs}"
+ [Print "<table border>\n<tr><th>Operator</th><th>Associated ident</th><th>Behavior in the default environment</th></tr>"];
+def_macro "\\end{tableauoperateurs}" [Print "</table>\n"];
+def_macro "\\entreeoperateur"
+ [Print "<tr><td>"; Print_arg; Print "</td><td>"; Print_arg;
+ Print "</td><td>"; Print_arg; Print "</td></tr>"];
+def_macro "\\fromoneto"
+ [Print "<i>"; Print_arg; Print "</i> = 1, ..., <i>";
+ Print_arg; Print "</i>"];
+def_macro "\\caml" [Print "<pre>"];
+def_macro "\\endcaml" [Print "</pre>"];
+def_macro "\\<" [Print "<u>"];
+def_macro "\\>" [Print "</u>"];
+def_macro "\\rminalltt" [Print_arg];
+def_macro "\\event" [Print "<font color=\"red\">*</font>"];
+def_macro "\\pdfchapter" [Skip_arg];
+def_macro "\\pdfchapterfold" [Skip_arg; Skip_arg];
+def_macro "\\pdfsection" [Skip_arg];
+def_macro "\\transl" [Print "<"; Print_arg; Print ">"];
+();;
+
--- /dev/null
+type action =
+ Print of string
+ | Print_arg
+ | Skip_arg;;
+
+val find_macro: string -> action list;;
+
+val def_macro: string -> action list -> unit;;
--- /dev/null
+let main () =
+ Latexscan.main (Lexing.from_channel stdin);;
+
+Printexc.print main (); exit 0;;
--- /dev/null
+{
+open Lexing;;
+open Latexmacros;;
+
+let delimiter = ref (char_of_int 0);;
+
+let upto delim lexfun lexbuf =
+ let old_delim = !delimiter in
+ delimiter := delim;
+ lexfun lexbuf;
+ delimiter := old_delim;;
+
+let verb_delim = ref (char_of_int 0);;
+
+let brace_nesting = ref 0;;
+
+let rindex c s =
+ let rec find i =
+ if i < 0 then raise Not_found else
+ if s.[i] = c then i else find (i-1) in
+ find (String.length s - 1);;
+
+let first_caml_line = ref true;;
+let in_caml = ref false;;
+}
+
+rule main = parse
+(* Comments *)
+ '%' [^ '\n'] * '\n' { main lexbuf }
+(* Paragraphs *)
+ | "\n\n" '\n' *
+ { print_string "<P>\n"; main lexbuf }
+(* Font changes *)
+ | "{\\it" " "* | "{\\em" " "*
+ { print_string "<i>"; upto '}' main lexbuf;
+ print_string "</i>"; main lexbuf }
+ | "{\\bf" " "* { print_string "<b>"; upto '}' main lexbuf;
+ print_string "</b>"; main lexbuf }
+ | "{\\rm" " "* { print_string "<u>"; upto '}' main lexbuf;
+ print_string "</u>"; main lexbuf }
+ | "{\\tt" " "* { print_string "<tt>"; upto '}' main lexbuf;
+ print_string "</tt>"; main lexbuf }
+ | '"' { print_string "<tt>"; indoublequote lexbuf;
+ print_string "</tt>"; main lexbuf }
+(* Verb, verbatim *)
+ | "\\verb" _ { verb_delim := lexeme_char lexbuf 5;
+ print_string "<tt>"; inverb lexbuf; print_string "</tt>";
+ main lexbuf }
+ | "\\begin{verbatim}"
+ { print_string "<pre>"; inverbatim lexbuf;
+ print_string "</pre>"; main lexbuf }
+(* Caml programs *)
+ | "\\caml"
+ { print_string "<pre>";
+ first_caml_line := true; in_caml := false;
+ camlprog lexbuf; print_string "</pre>"; main lexbuf }
+(* Raw html, latex only *)
+ | "\\begin{rawhtml}"
+ { rawhtml lexbuf; main lexbuf }
+ | "\\begin{latexonly}"
+ { latexonly lexbuf; main lexbuf }
+(* Itemize and similar environments *)
+ | "\\item[" { print_string "<dt>"; upto ']' main lexbuf;
+ print_string "<dd>"; main lexbuf }
+ | "\\item" { print_string "<li>"; main lexbuf }
+(* Math mode (hmph) *)
+ | "$" { main lexbuf }
+(* Special characters *)
+ | "\\char" ['0'-'9']+
+ { let lxm = lexeme lexbuf in
+ let code = String.sub lxm 5 (String.length lxm - 5) in
+ print_char(char_of_int(int_of_string code));
+ main lexbuf }
+ | "<" { print_string "<"; main lexbuf }
+ | ">" { print_string ">"; main lexbuf }
+ | "~" { print_string " "; main lexbuf }
+(* Definitions of very simple macros *)
+ | "\\def\\" (['A'-'Z' 'a'-'z']+ | [^ 'A'-'Z' 'a'-'z']) "{" [^ '{' '}']* "}"
+ { let s = lexeme lexbuf in
+ let l = String.length s in
+ let p = rindex '{' s in
+ let name = String.sub s 4 (p - 4) in
+ let expansion = String.sub s (p + 1) (l - p - 2) in
+ def_macro name [Print expansion];
+ main lexbuf }
+(* General case for environments and commands *)
+ | ("\\begin{" | "\\end{") ['A'-'Z' 'a'-'z']+ "}" |
+ "\\" (['A'-'Z' 'a'-'z']+ '*'? | [^ 'A'-'Z' 'a'-'z'])
+ { let exec_action = function
+ Print str -> print_string str
+ | Print_arg -> print_arg lexbuf
+ | Skip_arg -> skip_arg lexbuf in
+ List.iter exec_action (find_macro(lexeme lexbuf));
+ main lexbuf }
+(* Default rule for other characters *)
+ | eof { () }
+ | _ { let c = lexeme_char lexbuf 0 in
+ if c == !delimiter then () else (print_char c; main lexbuf) }
+
+and indoublequote = parse
+ '"' { () }
+ | "<" { print_string "<"; indoublequote lexbuf }
+ | ">" { print_string ">"; indoublequote lexbuf }
+ | "&" { print_string "&"; indoublequote lexbuf }
+ | "\\\"" { print_string "\""; indoublequote lexbuf }
+ | "\\\\" { print_string "\\"; indoublequote lexbuf }
+ | _ { print_char(lexeme_char lexbuf 0); indoublequote lexbuf }
+
+and inverb = parse
+ "<" { print_string "<"; inverb lexbuf }
+ | ">" { print_string ">"; inverb lexbuf }
+ | "&" { print_string "&"; inverb lexbuf }
+ | _ { let c = lexeme_char lexbuf 0 in
+ if c == !verb_delim then ()
+ else (print_char c; inverb lexbuf) }
+and inverbatim = parse
+ "<" { print_string "<"; inverbatim lexbuf }
+ | ">" { print_string ">"; inverbatim lexbuf }
+ | "&" { print_string "&"; inverbatim lexbuf }
+ | "\\end{verbatim}" { () }
+ | _ { print_char(lexeme_char lexbuf 0); inverbatim lexbuf }
+
+and camlprog = parse
+ "<" { print_string "<"; camlprog lexbuf }
+ | ">" { print_string ">"; camlprog lexbuf }
+ | "&" { print_string "&"; camlprog lexbuf }
+ | "\\?" { if !first_caml_line then begin
+ print_string "# <FONT COLOR=\"blue\">";
+ first_caml_line := false
+ end else
+ print_string " <FONT COLOR=\"blue\">";
+ in_caml := true;
+ camlprog lexbuf }
+ | "\\:" { print_string "<FONT COLOR=\"green\">";
+ in_caml := true;
+ camlprog lexbuf }
+ | "\\;" { first_caml_line := true; camlprog lexbuf }
+ | "\\\\" { print_string "\\"; camlprog lexbuf }
+ | "\\endcaml" { () }
+ | "\n" { if !in_caml then begin
+ print_string "</FONT>";
+ in_caml := false
+ end;
+ print_char '\n';
+ camlprog lexbuf }
+ | _ { print_char(lexeme_char lexbuf 0); camlprog lexbuf }
+
+and rawhtml = parse
+ "\\end{rawhtml}" { () }
+ | _ { print_char(lexeme_char lexbuf 0); rawhtml lexbuf }
+
+and latexonly = parse
+ "\\end{latexonly}" { () }
+ | _ { latexonly lexbuf }
+
+and print_arg = parse
+ [' ' '\n'] * "{" { upto '}' main lexbuf }
+ | _ { print_char(lexeme_char lexbuf 0); rawhtml lexbuf }
+
+and skip_arg = parse
+ "{" { incr brace_nesting; skip_arg lexbuf }
+ | "}" { decr brace_nesting;
+ if !brace_nesting > 0 then skip_arg lexbuf }
+ | _ { skip_arg lexbuf }
+
+
--- /dev/null
+#!/usr/local/bin/perl
+# Expand \input commands
+
+@path = split(/:/, $ENV{'TEXINPUTS'});
+
+while(<>) {
+ if (/^\\input\s*([^\s]*)/) {
+ do expand($1);
+ } else {
+ print $_;
+ }
+}
+
+sub expand {
+ local ($filename) = @_;
+ local (*INPUT);
+ $filename =~ s/\.tex$//;
+ $filename = do find_in_path($filename);
+ open(INPUT, $filename) || (warn("cannot find $filename"), return);
+ print "%%% $filename\n";
+ while(<INPUT>) {
+ if (/^\\input\s*([^\s]*)/) {
+ do expand($1);
+ } else {
+ print $_;
+ }
+ }
+ close(INPUT);
+}
+
+sub find_in_path {
+ local ($name) = @_;
+ local ($dir);
+ foreach $dir (@path) {
+ return "$dir/$name.htex" if (-f "$dir/$name.htex");
+ return "$dir/$name.tex" if (-f "$dir/$name.tex");
+ }
+ return $name;
+}
+
--- /dev/null
+#include <stdio.h>
+#include <ctype.h>
+
+char * transl[256];
+
+#define LINE_LENGTH 1024
+
+char line[LINE_LENGTH];
+
+int isprefix(s, pref)
+ char * s;
+ char * pref;
+{
+ while (1) {
+ if (*pref == 0) return 1;
+ if (*s == 0) return 0;
+ if (*s != *pref) return 0;
+ s++;
+ pref++;
+ }
+}
+
+int main(argc, argv)
+ int argc;
+ char * argv [];
+{
+ unsigned char * p;
+ int c;
+ int inquote;
+ int inverb;
+ int inverbatim_like;
+ int incaml;
+ int inverbatim = 0;
+ char *verbatim_end_in = "";
+ char *verbatim_end_out = "";
+
+ for (c = 0; c < 256; c++) transl[c] = NULL;
+#ifdef TIE_BLANKS
+ transl[' '] = "~";
+ transl['\n'] = "~";
+#else
+ transl[' '] = "\\ ";
+ transl['\n'] = "\\ ";
+#endif
+ transl['{'] = "{\\char123}";
+ transl['}'] = "{\\char125}";
+ transl['^'] = "{\\char94}";
+ transl['_'] = "{\\char95}";
+ transl['\\'] = "{\\char92}";
+ transl['~'] = "{\\char126}";
+ transl['$'] = "\\$";
+ transl['&'] = "{\\char38}";
+ transl['#'] = "\\#";
+ transl['%'] = "\\%";
+ transl['\''] = "{\\textquotesingle}";
+ transl['`'] = "{\\textasciigrave}";
+ inverbatim_like = 0;
+ incaml = 0;
+ inquote = 0;
+ inverbatim = 0;
+
+ puts ("% THIS FILE IS GENERATED.\n");
+
+ while(fgets(line, LINE_LENGTH, stdin) != NULL) {
+ if (inverbatim_like) {
+ fputs(line, stdout);
+ if (isprefix(line, "\\end{caml_")
+ || isprefix(line, "\\end{rawhtml}")) inverbatim_like = 0;
+ continue;
+ }
+ if (incaml) {
+ fputs(line, stdout);
+ if (isprefix(line, "\\endcamlexample")) incaml = 0;
+ continue;
+ }
+ if (inverbatim){
+ if (isprefix (line, verbatim_end_in)){
+ fputs (verbatim_end_out, stdout);
+ inverbatim = 0;
+ }else{
+ for (p = (unsigned char *) line; *p != 0; p++){
+ c = *p;
+ if (c == ' ' || c == '\n' || transl[c] == NULL){
+ putchar (c);
+ }else{
+ fputs (transl[c], stdout);
+ }
+ }
+ }
+ continue;
+ }
+ if (isprefix(line, "\\begin{caml_")
+ || isprefix(line, "\\begin{rawhtml}")) {
+ fputs(line, stdout);
+ inverbatim_like = 1;
+ continue;
+ }
+ if (isprefix(line, "\\camlexample")) {
+ fputs(line, stdout);
+ incaml = 1;
+ continue;
+ }
+ if (isprefix (line, "\\begin{verbatim}")){
+ fputs ("\\begin{machineenv}", stdout);
+ inverbatim = 1;
+ verbatim_end_in = "\\end{verbatim}";
+ verbatim_end_out = "\\end{machineenv}";
+ continue;
+ }
+ if (isprefix (line, "\\begin{ocamldoccode}")){
+ fputs ("\\begin{ocamldoccode}", stdout);
+ inverbatim = 1;
+ verbatim_end_in = "\\end{ocamldoccode}";
+ verbatim_end_out = "\\end{ocamldoccode}";
+ continue;
+ }
+ inverb = 0;
+ for (p = (unsigned char *) line; *p != 0; p++) {
+ c = *p;
+ if (inverb) {
+ if (c == inverb){
+ inverb = 0;
+ }else if (c == '\'' || c == '`'){
+ fprintf (stderr, "Warning: %c found in \\verb\n", c);
+ }
+ putchar(c);
+ continue;
+ }
+ switch(c) {
+ case '"':
+ if (inquote) {
+ fputs("}}", stdout);
+ inquote = 0;
+ } else {
+ fputs("{\\machine{", stdout);
+ inquote = 1;
+ }
+ break;
+ case '\\':
+ if (inquote) {
+ if (p[1] == '"' || p[1] == '\\') {
+ c = p[1];
+ p++;
+ }
+ if (transl[c] != NULL)
+ fputs(transl[c], stdout);
+ else
+ putchar(c);
+ } else if (isprefix(p, "\\verb") && p[5] != 0 && !isalpha(p[5])) {
+ inverb = p[5];
+ p = p + 5;
+ fputs("\\verb", stdout);
+ putchar(inverb);
+ } else {
+ putchar('\\');
+ }
+ break;
+ default:
+ if (inquote && transl[c] != NULL)
+ fputs(transl[c], stdout);
+ else
+ putchar(c);
+ }
+ }
+ }
+ return 0;
+}
--- /dev/null
+{
+ open Lexing;;
+ open Printf;;
+
+ let print_char_repr c =
+ match c with
+ | '\'' -> printf "{\\textquotesingle}"
+ | '`' -> printf "{\\textasciigrave}"
+ | _ -> printf "\\char%d" (int_of_char c);
+ ;;
+}
+
+rule main = parse
+ "\\begin{syntax}" {
+ print_string "\\begin{syntax}";
+ syntax lexbuf }
+ | "\\begin{verbatim}" | "\\camlexample" as s {
+ print_string s;
+ verbatim lexbuf }
+ | "\\@" {
+ print_string "@";
+ main lexbuf }
+ | "@" {
+ print_string "\\synt{";
+ syntax lexbuf }
+ | _ {
+ print_char (lexeme_char lexbuf 0); main lexbuf }
+ | eof {
+ () }
+
+and syntax = parse
+ "\\end{syntax}" {
+ print_string "\\end{syntax}";
+ main lexbuf }
+ | "@" {
+ print_string "}";
+ main lexbuf }
+ | '\'' {
+ print_string "\\token{";
+ inquote lexbuf }
+ | '\"' {
+ print_string "\\token{";
+ indoublequote lexbuf }
+ | "epsilon" { print_string "\\emptystring"; syntax lexbuf }
+ | ['a'-'z' 'A'-'Z'] ['a'-'z' 'A'-'Z' '0'-'9' '-'] * as lxm {
+ print_string "\\nonterm{";
+ print_string lxm ;
+ print_string"}";
+ syntax lexbuf }
+ | '@' (['a'-'z' 'A'-'Z'] ['a'-'z' 'A'-'Z' '0'-'9' '-'] * as lxm) '@' {
+ print_string "\\nt{";
+ print_string lxm ;
+ print_string"}";
+ syntax lexbuf }
+
+ | '\\' ['a'-'z''A'-'Z'] + {
+ print_string (lexeme lexbuf);
+ syntax lexbuf }
+ | ['_' '^'] _ {
+ print_string (lexeme lexbuf);
+ syntax lexbuf }
+ | "{" { print_string "\\brepet{}"; syntax lexbuf }
+ | "}" { print_string "\\erepet{}"; syntax lexbuf }
+ | "{{" { print_string "\\brepets{}"; syntax lexbuf }
+ | "}}" { print_string "\\erepets{}"; syntax lexbuf }
+ | "[" { print_string "\\boption{}"; syntax lexbuf }
+ | "]" { print_string "\\eoption{}"; syntax lexbuf }
+ | "(" { print_string "\\bparen{}"; syntax lexbuf }
+ | ")" { print_string "\\eparen{}"; syntax lexbuf }
+ | "||" { print_string "\\orelse{}"; syntax lexbuf }
+ | ":" { print_string "\\is{}"; syntax lexbuf }
+ | "|" { print_string "\\alt{}"; syntax lexbuf }
+ | ";" { print_string "\\sep{}"; syntax lexbuf }
+ | "\\\\" { print_string "\\cutline{}"; syntax lexbuf }
+ | _ {
+ print_char (lexeme_char lexbuf 0);
+ syntax lexbuf }
+
+and inquote = parse
+ ['A'-'Z' 'a'-'z' '0'-'9'] {
+ print_char (lexeme_char lexbuf 0);
+ inquote lexbuf }
+ | '\'' {
+ print_string "}";
+ syntax lexbuf }
+ | _ {
+ print_char_repr (lexeme_char lexbuf 0);
+ inquote lexbuf }
+
+and indoublequote = parse
+ ['A'-'Z' 'a'-'z' '0'-'9'] {
+ print_char (lexeme_char lexbuf 0);
+ indoublequote lexbuf }
+ | '"' {
+ print_string "}";
+ syntax lexbuf }
+ | _ {
+ print_char_repr (lexeme_char lexbuf 0);
+ indoublequote lexbuf }
+
+and verbatim = parse
+ "\n\\end{verbatim}"|"\\endcamlexample" as s {
+ print_string s;
+ main lexbuf }
+ | _ {
+ print_char (lexeme_char lexbuf 0);
+ verbatim lexbuf }
--- /dev/null
+let main() =
+ let lexbuf = Lexing.from_channel stdin in
+ if Array.length Sys.argv >= 2 && Sys.argv.(1) = "-html"
+ then Htmltransf.main lexbuf
+ else Transf.main lexbuf;
+ exit 0;;
+
+Printexc.print main ();;
| String of string
| Immutable_string of string
+let compare_floats x1 x2 =
+ (* It is important to compare the bit patterns here, so as not to
+ be subject to bugs such as GPR#295. *)
+ Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2)
+
let compare (x : t) (y : t) =
- let compare_floats x1 x2 =
- (* It is important to compare the bit patterns here, so as not to
- be subject to bugs such as GPR#295. *)
- Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2)
- in
let rec compare_float_lists l1 l2 =
match l1, l2 with
| [], [] -> 0
| String of string
| Immutable_string of string
+val compare_floats : float -> float -> int
+
val compare : t -> t -> int
val print : Format.formatter -> t -> unit
module type S = sig
val pass_name : string
- val variable_suffix : string
val what_to_specialise
: env:Inline_and_simplify_aux.Env.t
}
type t = {
- variable_suffix : string;
set_of_closures : Flambda.set_of_closures;
existing_definitions_via_spec_args_indexed_by_fun_var
: Definition.Set.t Variable.Map.t;
| existing_outer_var -> existing_outer_var.var, t
end
| Projection_from_existing_specialised_arg projection ->
- let new_outer_var =
- Variable.rename group ~append:t.variable_suffix
- in
+ let new_outer_var = Variable.rename group in
let projection = lift_projection t ~projection in
let new_outer_vars_indexed_by_new_lifted_defns =
Projection.Map.add
in
new_outer_var, t
in
- let new_inner_var =
- Variable.rename group ~append:t.variable_suffix
- in
+ let new_inner_var = Variable.rename group in
let new_inner_to_new_outer_vars =
Variable.Map.add new_inner_var new_outer_var
for_one_function.new_inner_to_new_outer_vars
if exists_already then t
else really_add_new_specialised_arg t ~group ~definition ~for_one_function
- let create ~env ~(what_to_specialise : W.t) ~variable_suffix =
+ let create ~env ~(what_to_specialise : W.t) =
let existing_definitions_via_spec_args_indexed_by_fun_var =
Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
if function_decl.stub then
what_to_specialise.set_of_closures.function_decls.funs
in
let t : t =
- { variable_suffix;
- set_of_closures = what_to_specialise.set_of_closures;
+ { set_of_closures = what_to_specialise.set_of_closures;
existing_definitions_via_spec_args_indexed_by_fun_var;
new_lifted_defns_indexed_by_new_outer_vars = Variable.Map.empty;
new_outer_vars_indexed_by_new_lifted_defns = Projection.Map.empty;
let rename_function_and_parameters ~fun_var
~(function_decl : Flambda.function_declaration) =
- let new_fun_var = Variable.rename fun_var ~append:T.variable_suffix in
+ let new_fun_var = Variable.rename fun_var in
let params_renaming_list =
List.map (fun param ->
- let new_param = Parameter.rename param ~append:T.variable_suffix in
+ let new_param = Parameter.rename param in
param, new_param)
function_decl.params
in
~inline:Default_inline
~specialise:Default_specialise
~is_a_functor:false
+ ~closure_origin:function_decl.closure_origin
in
new_fun_var, new_function_decl, rewritten_existing_specialised_args,
benefit
specialised_args, None
else
let function_decl, new_specialised_args =
- duplicate_function ~env ~set_of_closures ~fun_var
+ duplicate_function ~env ~set_of_closures ~fun_var ~new_fun_var
in
let specialised_args =
Variable.Map.disjoint_union specialised_args new_specialised_args
in
function_decl.params @ new_params
in
+ let closure_origin =
+ Closure_origin.create (Closure_id.wrap new_fun_var)
+ in
let rewritten_function_decl =
Flambda.create_function_declaration
~params:all_params
~inline:function_decl.inline
~specialise:function_decl.specialise
~is_a_functor:function_decl.is_a_functor
+ ~closure_origin
in
let funs, direct_call_surrogates =
if for_one_function.make_direct_call_surrogates then
- let surrogate = Variable.rename fun_var ~append:"_surrogate" in
+ let surrogate = Variable.rename fun_var in
let funs =
(* In this case, the original function declaration remains
untouched up to alpha-equivalence. Direct calls to it
~(set_of_closures : Flambda.set_of_closures) ~benefit
~new_lifted_defns_indexed_by_new_outer_vars =
let body =
- Flambda_utils.name_expr (Set_of_closures set_of_closures)
- ~name:("set_of_closures" ^ T.variable_suffix)
+ Flambda_utils.name_expr
+ ~name:Internal_variable_names.set_of_closures
+ (Set_of_closures set_of_closures)
in
Variable.Map.fold (fun new_outer_var (projection : Projection.t)
(expr, benefit) ->
let rewrite_set_of_closures_core ~env ~duplicate_function ~benefit
~(set_of_closures : Flambda.set_of_closures) =
let what_to_specialise =
- P.create ~env ~variable_suffix:T.variable_suffix
+ P.create ~env
~what_to_specialise:(T.what_to_specialise ~env ~set_of_closures)
in
let original_set_of_closures = set_of_closures in
module type S = sig
val pass_name : string
- val variable_suffix : string
val what_to_specialise
: env:Inline_and_simplify_aux.Env.t
env:Inline_and_simplify_aux.Env.t
-> set_of_closures:Flambda.set_of_closures
-> fun_var:Variable.t
+ -> new_fun_var:Variable.t
-> Flambda.function_declaration
* Flambda.specialised_to Variable.Map.t)
-> set_of_closures:Flambda.set_of_closures
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Chambart, OCamlPro *)
+(* Mark Shinwell, Leo White and Fu Yong Quah, Jane Street Europe *)
+(* *)
+(* Copyright 2013--2017 OCamlPro SAS *)
+(* Copyright 2014--2017 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+include Closure_id
+
+let create t = t
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Chambart, OCamlPro *)
+(* Mark Shinwell, Leo White and Fu Yong Quah, Jane Street Europe *)
+(* *)
+(* Copyright 2013--2017 OCamlPro SAS *)
+(* Copyright 2014--2017 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+include Identifiable.S
+
+val create : Closure_id.t -> t
+
+val get_compilation_unit : t -> Compilation_unit.t
if not (Ident.persistent id) then begin
Misc.fatal_error "Compilation_unit.create with non-persistent Ident.t"
end;
- { id; linkage_name; hash = Hashtbl.hash id.name }
+ { id; linkage_name; hash = Hashtbl.hash (Ident.name id); }
let get_persistent_ident cu = cu.id
let get_linkage_name cu = cu.linkage_name
let current = ref None
+let is_current arg =
+ match !current with
+ | None -> Misc.fatal_error "Current compilation unit is not set!"
+ | Some cur -> equal cur arg
let set_current t = current := Some t
let get_current () = !current
let get_current_exn () =
val get_persistent_ident : t -> Ident.t
val get_linkage_name : t -> Linkage_name.t
+val is_current : t -> bool
val set_current : t -> unit
val get_current : unit -> t option
val get_current_exn : unit -> t
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
-type t = {
- compilation_unit : Compilation_unit.t;
- ident : Ident.t;
-}
+include Variable
-include Identifiable.Make (struct
- type nonrec t = t
-
- let compare v1 v2 =
- let c = Ident.compare v1.ident v2.ident in
- if c = 0
- then Compilation_unit.compare v1.compilation_unit v2.compilation_unit
- else c
-
- let output c v = Ident.output c v.ident
-
- let hash v = Ident.hash v.ident
-
- let equal v1 v2 =
- Ident.same v1.ident v2.ident &&
- Compilation_unit.equal v1.compilation_unit v2.compilation_unit
-
- let print ppf v =
- Format.fprintf ppf "%a.%a"
- Compilation_unit.print v.compilation_unit
- Ident.print v.ident
-end)
-
-let create ?current_compilation_unit name =
- let compilation_unit =
- match current_compilation_unit with
- | Some compilation_unit -> compilation_unit
- | None -> Compilation_unit.get_current_exn ()
- in
- { compilation_unit;
- ident = Ident.create name;
- }
-
-let of_ident ident = create (Ident.name ident)
-
-let unique_ident t =
- { t.ident with
- name =
- Format.asprintf "%a_%s"
- Compilation_unit.print t.compilation_unit
- t.ident.name;
- }
-
-let rename ?current_compilation_unit ?append t =
- let compilation_unit =
- match current_compilation_unit with
- | Some compilation_unit -> compilation_unit
- | None -> Compilation_unit.get_current_exn ()
- in
- let ident =
- match append with
- | None -> Ident.rename t.ident
- | Some s -> Ident.create (t.ident.Ident.name ^ s)
- in
- { compilation_unit = compilation_unit;
- ident;
- }
-
-let freshen t =
- rename t ~current_compilation_unit:(Compilation_unit.get_current_exn ())
-
-let in_compilation_unit t cu =
- Compilation_unit.equal t.compilation_unit cu
-
-let output_full c t =
- Compilation_unit.output c t.compilation_unit;
- Printf.fprintf c ".";
- Ident.output c t.ident
+let create_from_variable = rename
include Identifiable.S
-val create : ?current_compilation_unit:Compilation_unit.t -> string -> t
-val of_ident : Ident.t -> t
+val create
+ : ?current_compilation_unit:Compilation_unit.t
+ -> Internal_variable_names.t
+ -> t
-(** For [Flambda_to_clambda] only. *)
-val unique_ident : t -> Ident.t
+val create_with_same_name_as_ident : Ident.t -> t
-val freshen : t -> t
+val create_from_variable
+ : ?current_compilation_unit:Compilation_unit.t
+ -> Variable.t
+ -> t
val rename
: ?current_compilation_unit:Compilation_unit.t
- -> ?append:string
-> t
-> t
val in_compilation_unit : t -> Compilation_unit.t -> bool
+val name : t -> string
+
+val unique_name : t -> string
+
+val print_list : Format.formatter -> t list -> unit
+val print_opt : Format.formatter -> t option -> unit
+
val output_full : out_channel -> t -> unit
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
-type t = {
- compilation_unit : Compilation_unit.t;
- label : Linkage_name.t;
- hash : int;
-}
+
+type t =
+ | Linkage of
+ { compilation_unit : Compilation_unit.t;
+ label : Linkage_name.t;
+ hash : int; }
+ | Variable of
+ { compilation_unit : Compilation_unit.t;
+ variable : Variable.t; }
+
+let label t =
+ match t with
+ | Linkage { label; _ } -> label
+ | Variable { variable; _ } ->
+ (* Use the variable's compilation unit for the label, since the
+ symbol's compilation unit might be a pack *)
+ let compilation_unit = Variable.get_compilation_unit variable in
+ let unit_linkage_name =
+ Linkage_name.to_string
+ (Compilation_unit.get_linkage_name compilation_unit)
+ in
+ let label = unit_linkage_name ^ "__" ^ Variable.unique_name variable in
+ Linkage_name.create label
include Identifiable.Make (struct
+
type nonrec t = t
let compare t1 t2 =
- (* Linkage names are unique across a whole project, so just comparing
- those is sufficient. *)
if t1 == t2 then 0
- else
- let c = compare t1.hash t2.hash in
- if c <> 0 then c
- else Linkage_name.compare t1.label t2.label
+ else begin
+ match t1, t2 with
+ | Linkage _, Variable _ -> 1
+ | Variable _, Linkage _ -> -1
+ | Linkage l1, Linkage l2 ->
+ let c = compare l1.hash l2.hash in
+ if c <> 0 then c else begin
+ (* Linkage names are unique across a whole project, so just comparing
+ those is sufficient. *)
+ Linkage_name.compare l1.label l2.label
+ end
+ | Variable v1, Variable v2 ->
+ Variable.compare v1.variable v2.variable
+ end
let equal x y =
if x == y then true
else compare x y = 0
- let output chan t = Linkage_name.output chan t.label
+ let output chan t =
+ Linkage_name.output chan (label t)
- let hash t = t.hash
+ let hash t =
+ match t with
+ | Linkage { hash; _ } -> hash
+ | Variable { variable } -> Variable.hash variable
let print ppf t =
- Compilation_unit.print ppf t.compilation_unit;
- Format.pp_print_string ppf ".";
- Linkage_name.print ppf t.label
+ Linkage_name.print ppf (label t)
+
end)
-let create compilation_unit label =
- let unit_linkage_name =
- Linkage_name.to_string
- (Compilation_unit.get_linkage_name compilation_unit)
- in
- let label =
- Linkage_name.create
- (unit_linkage_name ^ "__" ^ (Linkage_name.to_string label))
- in
+let of_global_linkage compilation_unit label =
let hash = Linkage_name.hash label in
- { compilation_unit; label; hash; }
+ Linkage { compilation_unit; hash; label }
-let unsafe_create compilation_unit label =
- let hash = Linkage_name.hash label in
- { compilation_unit; label; hash; }
+let of_variable variable =
+ let compilation_unit = Variable.get_compilation_unit variable in
+ Variable { variable; compilation_unit }
let import_for_pack ~pack:compilation_unit symbol =
- let hash = Linkage_name.hash symbol.label in
- { compilation_unit; label = symbol.label; hash; }
+ match symbol with
+ | Linkage l -> Linkage { l with compilation_unit }
+ | Variable v -> Variable { v with compilation_unit }
-let compilation_unit t = t.compilation_unit
-let label t = t.label
+let compilation_unit t =
+ match t with
+ | Linkage { compilation_unit; _ } -> compilation_unit
+ | Variable { compilation_unit; _ } -> compilation_unit
let print_opt ppf = function
| None -> Format.fprintf ppf "<no symbol>"
include Identifiable.S
-val create : Compilation_unit.t -> Linkage_name.t -> t
+val of_variable : Variable.t -> t
+
(* Create the symbol without prefixing with the compilation unit.
- Used for predefined exceptions *)
-val unsafe_create : Compilation_unit.t -> Linkage_name.t -> t
+ Used for global symbols like predefined exceptions *)
+val of_global_linkage : Compilation_unit.t -> Linkage_name.t -> t
val import_for_pack : pack:Compilation_unit.t -> t -> t
let previous_name_stamp = ref (-1)
-let create ?current_compilation_unit name =
+let create_with_name_string ?current_compilation_unit name =
let compilation_unit =
match current_compilation_unit with
| Some compilation_unit -> compilation_unit
name_stamp;
}
-let create_with_same_name_as_ident ident = create (Ident.name ident)
+let create ?current_compilation_unit name =
+ let name = (name : Internal_variable_names.t :> string) in
+ create_with_name_string ?current_compilation_unit name
-let clambda_name t =
- (Compilation_unit.string_for_printing t.compilation_unit) ^ "_" ^ t.name
+let create_with_same_name_as_ident ident =
+ create_with_name_string (Ident.name ident)
-let rename ?current_compilation_unit ?append t =
- let current_compilation_unit =
- match current_compilation_unit with
- | Some compilation_unit -> compilation_unit
- | None -> Compilation_unit.get_current_exn ()
- in
- let name =
- match append with
- | None -> t.name
- | Some s -> t.name ^ s
- in
- create ~current_compilation_unit name
+let rename ?current_compilation_unit t =
+ create_with_name_string ?current_compilation_unit t.name
let in_compilation_unit t cu =
Compilation_unit.equal cu t.compilation_unit
let get_compilation_unit t = t.compilation_unit
+let name t = t.name
+
let unique_name t =
t.name ^ "_" ^ (string_of_int t.name_stamp)
include Identifiable.S
-val create : ?current_compilation_unit:Compilation_unit.t -> string -> t
+val create
+ : ?current_compilation_unit:Compilation_unit.t
+ -> Internal_variable_names.t
+ -> t
val create_with_same_name_as_ident : Ident.t -> t
-val clambda_name : t -> string
-(* CR-someday pchambart: Should we propagate Variable.t into clambda ??? *)
-
val rename
: ?current_compilation_unit:Compilation_unit.t
- -> ?append:string
-> t
-> t
val in_compilation_unit : t -> Compilation_unit.t -> bool
+val name : t -> string
+
val unique_name : t -> string
val get_compilation_unit : t -> Compilation_unit.t
module Env = Closure_conversion_aux.Env
module Function_decls = Closure_conversion_aux.Function_decls
module Function_decl = Function_decls.Function_decl
-module IdentSet = Lambda.IdentSet
+module Names = Internal_variable_names
let name_expr = Flambda_utils.name_expr
+let name_expr_from_var = Flambda_utils.name_expr_from_var
type t = {
current_unit_id : Ident.t;
(** Generate a wrapper ("stub") function that accepts a tuple argument and
calls another function with arguments extracted in the obvious
manner from the tuple. *)
-let tupled_function_call_stub original_params unboxed_version
+let tupled_function_call_stub original_params unboxed_version ~closure_bound_var
: Flambda.function_declaration =
- let tuple_param_var =
- Variable.rename ~append:"tupled_stub_param" unboxed_version
- in
+ let tuple_param_var = Variable.rename unboxed_version in
let params = List.map (fun p -> Variable.rename p) original_params in
let call : Flambda.t =
Apply ({
Flambda.create_function_declaration ~params:[tuple_param]
~body ~stub:true ~dbg:Debuginfo.none ~inline:Default_inline
~specialise:Default_specialise ~is_a_functor:false
+ ~closure_origin:(Closure_origin.create (Closure_id.wrap closure_bound_var))
let register_const t (constant:Flambda.constant_defining_value) name
- : Flambda.constant_defining_value_block_field * string =
- let current_compilation_unit = Compilation_unit.get_current_exn () in
- (* Create a variable to ensure uniqueness of the symbol *)
- let var = Variable.create ~current_compilation_unit name in
- let symbol =
- Symbol.create current_compilation_unit
- (Linkage_name.create (Variable.unique_name var))
- in
+ : Flambda.constant_defining_value_block_field * Internal_variable_names.t =
+ let var = Variable.create name in
+ let symbol = Symbol.of_variable var in
t.declared_symbols <- (symbol, constant) :: t.declared_symbols;
Symbol symbol, name
let rec declare_const t (const : Lambda.structured_constant)
- : Flambda.constant_defining_value_block_field * string =
+ : Flambda.constant_defining_value_block_field * Internal_variable_names.t =
match const with
- | Const_base (Const_int c) -> Const (Int c), "int"
- | Const_base (Const_char c) -> Const (Char c), "char"
+ | Const_base (Const_int c) -> (Const (Int c), Names.const_int)
+ | Const_base (Const_char c) -> (Const (Char c), Names.const_char)
| Const_base (Const_string (s, _)) ->
let const, name =
if Config.safe_string then
- Flambda.Allocated_const (Immutable_string s), "immstring"
- else Flambda.Allocated_const (String s), "string"
+ (Flambda.Allocated_const (Immutable_string s),
+ Names.const_immstring)
+ else
+ (Flambda.Allocated_const (String s),
+ Names.const_string)
in
register_const t const name
| Const_base (Const_float c) ->
register_const t
(Allocated_const (Float (float_of_string c)))
- "float"
+ Names.const_float
| Const_base (Const_int32 c) ->
- register_const t (Allocated_const (Int32 c)) "int32"
+ register_const t (Allocated_const (Int32 c))
+ Names.const_int32
| Const_base (Const_int64 c) ->
- register_const t (Allocated_const (Int64 c)) "int64"
+ register_const t (Allocated_const (Int64 c))
+ Names.const_int64
| Const_base (Const_nativeint c) ->
- register_const t (Allocated_const (Nativeint c)) "nativeint"
- | Const_pointer c -> Const (Const_pointer c), "pointer"
+ register_const t (Allocated_const (Nativeint c)) Names.const_nativeint
+ | Const_pointer c -> Const (Const_pointer c), Names.const_ptr
| Const_immstring c ->
- register_const t (Allocated_const (Immutable_string c)) "immstring"
+ register_const t (Allocated_const (Immutable_string c))
+ Names.const_immstring
| Const_float_array c ->
register_const t
(Allocated_const (Immutable_float_array (List.map float_of_string c)))
- "float_array"
+ Names.const_float_array
| Const_block (tag, consts) ->
let const : Flambda.constant_defining_value =
Block (Tag.create_exn tag,
List.map (fun c -> fst (declare_const t c)) consts)
in
- register_const t const "const_block"
+ register_const t const Names.const_block
let close_const t (const : Lambda.structured_constant)
- : Flambda.named * string =
+ : Flambda.named * Internal_variable_names.t =
match declare_const t const with
| Const c, name ->
Const c, name
| var -> Var var
| exception Not_found ->
match Env.find_mutable_var_exn env id with
- | mut_var -> name_expr (Read_mutable mut_var) ~name:"read_mutable"
+ | mut_var ->
+ name_expr (Read_mutable mut_var) ~name:Names.read_mutable
| exception Not_found ->
Misc.fatal_errorf "Closure_conversion.close: unbound identifier %a"
Ident.print id
end
| Lconst cst ->
let cst, name = close_const t cst in
- name_expr cst ~name:("const_" ^ name)
+ name_expr cst ~name
| Llet ((Strict | Alias | StrictOpt), _value_kind, id, defining_expr, body) ->
(* TODO: keep value_kind in flambda *)
let var = Variable.create_with_same_name_as_ident id in
let body = close t (Env.add_var env id var) body in
Flambda.create_let var defining_expr body
| Llet (Variable, block_kind, id, defining_expr, body) ->
- let mut_var = Mutable_variable.of_ident id in
+ let mut_var = Mutable_variable.create_with_same_name_as_ident id in
let var = Variable.create_with_same_name_as_ident id in
let defining_expr =
close_let_bound_expression t var env defining_expr
body;
contents_kind = block_kind })
| Lfunction { kind; params; body; attr; loc; } ->
- let name =
- (* Name anonymous functions by their source location, if known. *)
- if loc = Location.none then "anon-fn"
- else Format.asprintf "anon-fn[%a]" Location.print_compact loc
- in
+ let name = Names.anon_fn_with_loc loc in
let closure_bound_var = Variable.create name in
(* CR-soon mshinwell: some of this is now very similar to the let rec case
below *)
- let set_of_closures_var = Variable.create ("set_of_closures_" ^ name) in
+ let set_of_closures_var = Variable.create Names.set_of_closures in
let set_of_closures =
let decl =
Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind
}
in
Flambda.create_let set_of_closures_var set_of_closures
- (name_expr (Project_closure (project_closure))
- ~name:("project_closure_" ^ name))
+ (name_expr (Project_closure (project_closure)) ~name)
| Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall = _;
ap_inlined; ap_specialised; } ->
Lift_code.lifting_helper (close_list t env ap_args)
~evaluation_order:`Right_to_left
- ~name:"apply_arg"
+ ~name:Names.apply_arg
~create_body:(fun args ->
let func = close t env ap_func in
- let func_var = Variable.create "apply_funct" in
+ let func_var = Variable.create Names.apply_funct in
Flambda.create_let func_var (Expr func)
(Apply ({
func = func_var;
(* CR-someday lwhite: This is a very syntactic criteria. Adding an
unused value to a set of recursive bindings changes how
functions are represented at runtime. *)
- let name =
- (* The Microsoft assembler has a 247-character limit on symbol
- names, so we keep them shorter to try not to hit this. *)
- if Sys.win32 then begin
- match defs with
- | (id, _)::_ -> (Ident.unique_name id) ^ "_let_rec"
- | _ -> "let_rec"
- end else begin
- String.concat "_and_"
- (List.map (fun (id, _) -> Ident.unique_name id) defs)
- end
- in
- let set_of_closures_var = Variable.create name in
+ let set_of_closures_var = Variable.create (Names.set_of_closures) in
let set_of_closures =
close_functions t env (Function_decls.create function_declarations)
in
Let_rec (defs, close t env body)
end
| Lsend (kind, meth, obj, args, loc) ->
- let meth_var = Variable.create "meth" in
- let obj_var = Variable.create "obj" in
+ let meth_var = Variable.create Names.meth in
+ let obj_var = Variable.create Names.obj in
let dbg = Debuginfo.from_location loc in
Flambda.create_let meth_var (Expr (close t env meth))
(Flambda.create_let obj_var (Expr (close t env obj))
(Lift_code.lifting_helper (close_list t env args)
~evaluation_order:`Right_to_left
- ~name:"send_arg"
+ ~name:Names.send_arg
~create_body:(fun args ->
Send { kind; meth = meth_var; obj = obj_var; args; dbg; })))
| Lprim ((Pdivint Safe | Pmodint Safe
when not !Clflags.fast -> (* not -unsafe *)
let arg2 = close t env arg2 in
let arg1 = close t env arg1 in
- let numerator = Variable.create "numerator" in
- let denominator = Variable.create "denominator" in
- let zero = Variable.create "zero" in
- let is_zero = Variable.create "is_zero" in
- let exn = Variable.create "division_by_zero" in
+ let numerator = Variable.create Names.numerator in
+ let denominator = Variable.create Names.denominator in
+ let zero = Variable.create Names.zero in
+ let is_zero = Variable.create Names.is_zero in
+ let exn = Variable.create Names.division_by_zero in
let exn_symbol =
t.symbol_for_global' Predef.ident_division_by_zero
in
(Prim (comparison, [zero; denominator], dbg))
(If_then_else (is_zero,
name_expr (Prim (Praise Raise_regular, [exn], dbg))
- ~name:"dummy",
+ ~name:Names.dummy,
(* CR-someday pchambart: find the right event.
mshinwell: I briefly looked at this, and couldn't
figure it out.
are suitable. I had to add a new one for a similar
case in the array data types work.
mshinwell: deferred CR *)
- name_expr ~name:"result"
+ name_expr ~name:Names.result
(Prim (prim, [numerator; denominator], dbg))))))))
| Lprim ((Pdivint Safe | Pmodint Safe
| Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }), _, _)
| Lprim (Psequor, [arg1; arg2], _) ->
let arg1 = close t env arg1 in
let arg2 = close t env arg2 in
- let const_true = Variable.create "const_true" in
- let cond = Variable.create "cond_sequor" in
+ let const_true = Variable.create Names.const_true in
+ let cond = Variable.create Names.cond_sequor in
Flambda.create_let const_true (Const (Const_pointer 1))
(Flambda.create_let cond (Expr arg1)
(If_then_else (cond, Var const_true, arg2)))
| Lprim (Psequand, [arg1; arg2], _) ->
let arg1 = close t env arg1 in
let arg2 = close t env arg2 in
- let const_false = Variable.create "const_false" in
- let cond = Variable.create "cond_sequand" in
+ let const_false = Variable.create Names.const_false in
+ let cond = Variable.create Names.const_sequand in
Flambda.create_let const_false (Const (Const_pointer 0))
(Flambda.create_let cond (Expr arg1)
(If_then_else (cond, arg2, Var const_false)))
in
close t env (Lambda.Lapply apply)
| Lprim (Praise kind, [arg], loc) ->
- let arg_var = Variable.create "raise_arg" in
+ let arg_var = Variable.create Names.raise_arg in
let dbg = Debuginfo.from_location loc in
Flambda.create_let arg_var (Expr (close t env arg))
(name_expr
(Prim (Praise kind, [arg_var], dbg))
- ~name:"raise")
+ ~name:Names.raise)
| Lprim (Pfield _, [Lprim (Pgetglobal id, [],_)], _)
when Ident.same id t.current_unit_id ->
Misc.fatal_errorf "[Pfield (Pgetglobal ...)] for the current compilation \
| Lprim (Pgetglobal id, [], _) when Ident.is_predef_exn id ->
let symbol = t.symbol_for_global' id in
t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols;
- name_expr (Symbol symbol) ~name:"predef_exn"
+ name_expr (Symbol symbol) ~name:Names.predef_exn
| Lprim (Pgetglobal id, [], _) ->
assert (not (Ident.same id t.current_unit_id));
let symbol = t.symbol_for_global' id in
t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols;
- name_expr (Symbol symbol) ~name:"Pgetglobal"
+ name_expr (Symbol symbol) ~name:Names.pgetglobal
| Lprim (p, args, loc) ->
(* One of the important consequences of the ANF-like representation
here is that we obtain names corresponding to the components of
by the simplification pass to increase the likelihood of eliminating
the allocation, since some field accesses can be tracked back to known
field values. *)
- let name = Printlambda.name_of_primitive p in
let dbg = Debuginfo.from_location loc in
Lift_code.lifting_helper (close_list t env args)
~evaluation_order:`Right_to_left
- ~name:(name ^ "_arg")
+ ~name:(Names.of_primitive_arg p)
~create_body:(fun args ->
name_expr (Prim (p, args, dbg))
- ~name)
+ ~name:(Names.of_primitive p))
| Lswitch (arg, sw, _loc) ->
- let scrutinee = Variable.create "switch" in
+ let scrutinee = Variable.create Names.switch in
let aux (i, lam) = i, close t env lam in
- let zero_to_n = Numbers.Int.zero_to_n in
+ let nums sw_num cases default =
+ let module I = Numbers.Int in
+ match default with
+ | Some _ ->
+ I.zero_to_n (sw_num - 1)
+ | None ->
+ List.fold_left (fun set (i, _) -> I.Set.add i set) I.Set.empty cases
+ in
Flambda.create_let scrutinee (Expr (close t env arg))
(Switch (scrutinee,
- { numconsts = zero_to_n (sw.sw_numconsts - 1);
+ { numconsts = nums sw.sw_numconsts sw.sw_consts sw.sw_failaction;
consts = List.map aux sw.sw_consts;
- numblocks = zero_to_n (sw.sw_numblocks - 1);
+ numblocks = nums sw.sw_numblocks sw.sw_blocks sw.sw_failaction;
blocks = List.map aux sw.sw_blocks;
failaction = Misc.may_map (close t env) sw.sw_failaction;
}))
| Lstringswitch (arg, sw, def, _) ->
- let scrutinee = Variable.create "string_switch" in
+ let scrutinee = Variable.create Names.string_switch in
Flambda.create_let scrutinee (Expr (close t env arg))
(String_switch (scrutinee,
List.map (fun (s, e) -> s, close t env e) sw,
| Lstaticraise (i, args) ->
Lift_code.lifting_helper (close_list t env args)
~evaluation_order:`Right_to_left
- ~name:"staticraise_arg"
+ ~name:Names.staticraise_arg
~create_body:(fun args ->
let static_exn = Env.find_static_exception env i in
Static_raise (static_exn, args))
Try_with (close t env body, var, close t (Env.add_var env id var) handler)
| Lifthenelse (cond, ifso, ifnot) ->
let cond = close t env cond in
- let cond_var = Variable.create "cond" in
+ let cond_var = Variable.create Names.cond in
Flambda.create_let cond_var (Expr cond)
(If_then_else (cond_var, close t env ifso, close t env ifnot))
| Lsequence (lam1, lam2) ->
- let var = Variable.create "sequence" in
+ let var = Variable.create Names.sequence in
let lam1 = Flambda.Expr (close t env lam1) in
let lam2 = close t env lam2 in
Flambda.create_let var lam1 lam2
| Lwhile (cond, body) -> While (close t env cond, close t env body)
| Lfor (id, lo, hi, direction, body) ->
let bound_var = Variable.create_with_same_name_as_ident id in
- let from_value = Variable.create "for_from" in
- let to_value = Variable.create "for_to" in
+ let from_value = Variable.create Names.for_from in
+ let to_value = Variable.create Names.for_to in
let body = close t (Env.add_var env id bound_var) body in
Flambda.create_let from_value (Expr (close t env lo))
(Flambda.create_let to_value (Expr (close t env hi))
variable %s in assignment"
(Ident.unique_name id)
in
- let new_value_var = Variable.create "new_value" in
+ let new_value_var = Variable.create Names.new_value in
Flambda.create_let new_value_var (Expr (close t env new_value))
(Assign { being_assigned; new_value = new_value_var; })
| Levent (lam, _) -> close t env lam
let param_vars = List.map (Env.find_var closure_env) params in
let params = List.map Parameter.wrap param_vars in
let closure_bound_var = Function_decl.closure_bound_var decl in
+ let unboxed_version = Variable.rename closure_bound_var in
let body = close t closure_env body in
+ let closure_origin =
+ Closure_origin.create (Closure_id.wrap unboxed_version)
+ in
let fun_decl =
Flambda.create_function_declaration ~params ~body ~stub ~dbg
~inline:(Function_decl.inline decl)
~specialise:(Function_decl.specialise decl)
~is_a_functor:(Function_decl.is_a_functor decl)
+ ~closure_origin
in
match Function_decl.kind decl with
| Curried -> Variable.Map.add closure_bound_var fun_decl map
| Tupled ->
let unboxed_version = Variable.rename closure_bound_var in
let generic_function_stub =
- tupled_function_call_stub param_vars unboxed_version
+ tupled_function_call_stub param_vars unboxed_version ~closure_bound_var
in
Variable.Map.add unboxed_version fun_decl
(Variable.Map.add closure_bound_var generic_function_stub map)
in
let function_decls =
- Flambda.create_function_declarations
- ~funs:
- (List.fold_left close_one_function Variable.Map.empty
- (Function_decls.to_list function_declarations))
+ let is_classic_mode = !Clflags.classic_inlining in
+ let funs =
+ List.fold_left close_one_function Variable.Map.empty
+ (Function_decls.to_list function_declarations)
+ in
+ Flambda.create_function_declarations ~is_classic_mode ~funs
in
(* The closed representation of a set of functions is a "set of closures".
(For avoidance of doubt, the runtime representation of the *whole set* is
a single block with tag [Closure_tag].) *)
let set_of_closures =
let free_vars =
- IdentSet.fold (fun var map ->
+ Ident.Set.fold (fun var map ->
let internal_var =
Env.find_var closure_env_without_parameters var
in
Function_decl.create ~let_rec_ident ~closure_bound_var ~kind ~params
~body ~attr ~loc
in
- let set_of_closures_var =
- Variable.rename let_bound_var ~append:"_set_of_closures"
- in
+ let set_of_closures_var = Variable.rename let_bound_var in
let set_of_closures =
close_functions t env (Function_decls.create [decl])
in
}
in
Expr (Flambda.create_let set_of_closures_var set_of_closures
- (name_expr (Project_closure (project_closure))
- ~name:(Variable.unique_name let_bound_var)))
+ (name_expr_from_var (Project_closure (project_closure))
+ ~var:let_bound_var))
| lam -> Expr (close t env lam)
let lambda_to_flambda ~backend ~module_ident ~size ~filename lam
in
let module_symbol = Backend.symbol_for_global' module_ident in
let block_symbol =
- let linkage_name = Linkage_name.create "module_as_block" in
- Symbol.create compilation_unit linkage_name
+ let var = Variable.create Internal_variable_names.module_as_block in
+ Symbol.of_variable var
in
(* The global module block is built by accessing the fields of all the
introduced symbols. *)
compiled. *)
let fields =
Array.init size (fun pos ->
- let pos_str = string_of_int pos in
- let sym_v = Variable.create ("block_symbol_" ^ pos_str) in
- let result_v = Variable.create ("block_symbol_get_" ^ pos_str) in
- let value_v = Variable.create ("block_symbol_get_field_" ^ pos_str) in
+ let sym_v = Variable.create Names.block_symbol in
+ let result_v = Variable.create Names.block_symbol_get in
+ let value_v = Variable.create Names.block_symbol_get_field in
Flambda.create_let
sym_v (Symbol block_symbol)
(Flambda.create_let result_v
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
-module IdentSet = Lambda.IdentSet
-
module Env = struct
type t = {
variables : Variable.t Ident.tbl;
kind : Lambda.function_kind;
params : Ident.t list;
body : Lambda.lambda;
- free_idents_of_body : IdentSet.t;
+ free_idents_of_body : Ident.Set.t;
attr : Lambda.function_attribute;
loc : Location.t;
}
type t = {
function_decls : Function_decl.t list;
- all_free_idents : IdentSet.t;
+ all_free_idents : Ident.Set.t;
}
(* All identifiers free in the bodies of the given function declarations,
function_decls Variable.Map.empty
let all_free_idents function_decls =
- Variable.Map.fold (fun _ -> IdentSet.union)
- (free_idents_by_function function_decls) IdentSet.empty
+ Variable.Map.fold (fun _ -> Ident.Set.union)
+ (free_idents_by_function function_decls) Ident.Set.empty
(* All identifiers of simultaneously-defined functions in [ts]. *)
let let_rec_idents function_decls =
let all_params function_decls =
List.concat (List.map Function_decl.params function_decls)
- let set_diff (from : IdentSet.t) (idents : Ident.t list) =
- List.fold_right IdentSet.remove idents from
+ let set_diff (from : Ident.Set.t) (idents : Ident.t list) =
+ List.fold_right Ident.Set.remove idents from
(* CR-someday lwhite: use a different name from above or explain the
difference *)
t.function_decls (Env.clear_local_bindings external_env)
in
(* For free variables. *)
- IdentSet.fold (fun id env ->
- Env.add_var env id (Variable.create (Ident.name id)))
+ Ident.Set.fold (fun id env ->
+ Env.add_var env id (Variable.create_with_same_name_as_ident id))
t.all_free_idents closure_env
end
val loc : t -> Location.t
(* Like [all_free_idents], but for just one function. *)
- val free_idents : t -> Lambda.IdentSet.t
+ val free_idents : t -> Ident.Set.t
end
type t
(* All identifiers free in the given function declarations after the binding
of parameters and function identifiers has been performed. *)
- val all_free_idents : t -> Lambda.IdentSet.t
+ val all_free_idents : t -> Ident.Set.t
(* A map from identifiers to their corresponding [Variable.t]s whose domain
is the set of all identifiers free in the bodies of the declarations that
}
and function_declarations = {
+ is_classic_mode : bool;
set_of_closures_id : Set_of_closures_id.t;
set_of_closures_origin : Set_of_closures_origin.t;
funs : function_declaration Variable.Map.t;
}
and function_declaration = {
+ closure_origin: Closure_origin.t;
params : Parameter.t list;
body : t;
free_variables : Variable.Set.t;
in
fprintf ppf "@[<2>(set_of_closures id=%a@ %a@ @[<2>free_vars={%a@ }@]@ \
@[<2>specialised_args={%a})@]@ \
- @[<2>direct_call_surrogates=%a@]@]"
+ @[<2>direct_call_surrogates=%a@]@ \
+ @[<2>set_of_closures_origin=%a@]@]]"
Set_of_closures_id.print function_decls.set_of_closures_id
funs function_decls.funs
vars free_vars
spec specialised_args
(Variable.Map.print Variable.print)
set_of_closures.direct_call_surrogates
+ Set_of_closures_origin.print function_decls.set_of_closures_origin
and print_const ppf (c : const) =
match c with
let funs ppf =
Variable.Map.iter (print_function_declaration ppf)
in
- fprintf ppf "@[<2>(%a)@]" funs fd.funs
+ fprintf ppf "@[<2>(%a)(origin = %a)@]" funs fd.funs
+ Set_of_closures_origin.print fd.set_of_closures_origin
let print ppf flam =
fprintf ppf "%a@." lam flam
loop program.program_body;
!symbols
+let update_body_of_function_declaration (func_decl: function_declaration)
+ ~body : function_declaration =
+ { closure_origin = func_decl.closure_origin;
+ params = func_decl.params;
+ body;
+ free_variables = free_variables body;
+ free_symbols = free_symbols body;
+ stub = func_decl.stub;
+ dbg = func_decl.dbg;
+ inline = func_decl.inline;
+ specialise = func_decl.specialise;
+ is_a_functor = func_decl.is_a_functor;
+ }
+
+let update_function_decl's_params_and_body
+ (func_decl : function_declaration) ~params ~body =
+ { closure_origin = func_decl.closure_origin;
+ params;
+ body;
+ free_variables = free_variables body;
+ free_symbols = free_symbols body;
+ stub = func_decl.stub;
+ dbg = func_decl.dbg;
+ inline = func_decl.inline;
+ specialise = func_decl.specialise;
+ is_a_functor = func_decl.is_a_functor;
+ }
+
+
let create_function_declaration ~params ~body ~stub ~dbg
~(inline : Lambda.inline_attribute)
~(specialise : Lambda.specialise_attribute) ~is_a_functor
+ ~closure_origin
: function_declaration =
begin match stub, inline with
| true, (Never_inline | Default_inline)
"Stubs may not be annotated as [Always_specialise]: %a"
print body
end;
- { params;
+ { closure_origin;
+ params;
body;
free_variables = free_variables body;
free_symbols = free_symbols body;
is_a_functor;
}
-let create_function_declarations ~funs =
+let update_function_declaration fun_decl ~params ~body =
+ let free_variables = free_variables body in
+ let free_symbols = free_symbols body in
+ { fun_decl with params; body; free_variables; free_symbols }
+
+let create_function_declarations ~is_classic_mode ~funs =
let compilation_unit = Compilation_unit.get_current_exn () in
let set_of_closures_id = Set_of_closures_id.create compilation_unit in
let set_of_closures_origin =
Set_of_closures_origin.create set_of_closures_id
in
- { set_of_closures_id;
+ { is_classic_mode;
+ set_of_closures_id;
+ set_of_closures_origin;
+ funs;
+ }
+
+let create_function_declarations_with_origin
+ ~is_classic_mode ~funs ~set_of_closures_origin =
+ let compilation_unit = Compilation_unit.get_current_exn () in
+ let set_of_closures_id = Set_of_closures_id.create compilation_unit in
+ { is_classic_mode;
+ set_of_closures_id;
set_of_closures_origin;
funs;
}
let update_function_declarations function_decls ~funs =
+ let is_classic_mode = function_decls.is_classic_mode in
let compilation_unit = Compilation_unit.get_current_exn () in
let set_of_closures_id = Set_of_closures_id.create compilation_unit in
let set_of_closures_origin = function_decls.set_of_closures_origin in
- { set_of_closures_id;
+ { is_classic_mode;
+ set_of_closures_id;
set_of_closures_origin;
funs;
}
+let create_function_declarations_with_closures_origin
+ ~is_classic_mode ~funs ~set_of_closures_origin =
+ let compilation_unit = Compilation_unit.get_current_exn () in
+ let set_of_closures_id = Set_of_closures_id.create compilation_unit in
+ { is_classic_mode;
+ set_of_closures_id;
+ set_of_closures_origin;
+ funs
+ }
+
let import_function_declarations_for_pack function_decls
- import_set_of_closures_id import_set_of_closures_origin =
- { set_of_closures_id =
- import_set_of_closures_id function_decls.set_of_closures_id;
- set_of_closures_origin =
- import_set_of_closures_origin function_decls.set_of_closures_origin;
- funs = function_decls.funs;
+ import_set_of_closures_id import_set_of_closures_origin =
+ let is_classic_mode = function_decls.is_classic_mode in
+ let set_of_closures_id =
+ import_set_of_closures_id function_decls.set_of_closures_id
+ in
+ let set_of_closures_origin =
+ import_set_of_closures_origin function_decls.set_of_closures_origin
+ in
+ let funs = function_decls.funs in
+ { is_classic_mode;
+ set_of_closures_id;
+ set_of_closures_origin;
+ funs;
}
let create_set_of_closures ~function_decls ~free_vars ~specialised_args
}
and function_declarations = private {
+ is_classic_mode: bool;
+ (** Indicates whether this [function_declarations] was compiled
+ with -Oclassic. *)
set_of_closures_id : Set_of_closures_id.t;
(** An identifier (unique across all Flambda trees currently in memory)
of the set of closures associated with this set of function
}
and function_declaration = private {
+ closure_origin: Closure_origin.t;
params : Parameter.t list;
body : t;
(* CR-soon mshinwell: inconsistent naming free_variables/free_vars here and
-> inline:Lambda.inline_attribute
-> specialise:Lambda.specialise_attribute
-> is_a_functor:bool
+ -> closure_origin:Closure_origin.t
+ -> function_declaration
+
+(** Create a function declaration based on another function declaration *)
+val update_function_declaration
+ : function_declaration
+ -> params:Parameter.t list
+ -> body:t
-> function_declaration
(** Create a set of function declarations given the individual declarations. *)
val create_function_declarations
- : funs:function_declaration Variable.Map.t
+ : is_classic_mode:bool
+ -> funs:function_declaration Variable.Map.t
+ -> function_declarations
+
+(** Create a set of function declarations with a given set of closures
+ origin. *)
+val create_function_declarations_with_origin
+ : is_classic_mode:bool
+ -> funs:function_declaration Variable.Map.t
+ -> set_of_closures_origin:Set_of_closures_origin.t
-> function_declarations
+(** Change only the code of a function declaration. *)
+val update_body_of_function_declaration
+ : function_declaration
+ -> body:expr
+ -> function_declaration
+
+(** Change only the code and parameters of a function declaration. *)
+(* CR-soon mshinwell: rename this to match new update function above *)
+val update_function_decl's_params_and_body
+ : function_declaration
+ -> params:Parameter.t list
+ -> body:expr
+ -> function_declaration
+
(** Create a set of function declarations based on another set of function
declarations. *)
val update_function_declarations
-> funs:function_declaration Variable.Map.t
-> function_declarations
+val create_function_declarations_with_closures_origin
+ : is_classic_mode: bool
+ -> funs:function_declaration Variable.Map.t
+ -> set_of_closures_origin:Set_of_closures_origin.t
+ -> function_declarations
+
val import_function_declarations_for_pack
: function_declarations
-> (Set_of_closures_id.t -> Set_of_closures_id.t)
exception Pidentity_should_not_occur
exception Pdirapply_should_be_expanded
exception Prevapply_should_be_expanded
-exception Ploc_should_be_expanded
exception Sequential_logical_operator_primitives_must_be_expanded of
Lambda.primitive
exception Var_within_closure_bound_multiple_times of Var_within_closure.t
({ Flambda.function_decls; free_vars; specialised_args;
direct_call_surrogates = _; } as set_of_closures) =
(* CR-soon mshinwell: check [direct_call_surrogates] *)
- let { Flambda.set_of_closures_id; set_of_closures_origin; funs; } =
+ let { Flambda. is_classic_mode;
+ set_of_closures_id; set_of_closures_origin; funs; } =
function_decls
in
+ ignore (is_classic_mode : bool);
ignore_set_of_closures_id set_of_closures_id;
ignore_set_of_closures_origin set_of_closures_origin;
let functions_in_closure = Variable.Map.keys funs in
| Pidentity -> raise Pidentity_should_not_occur
| Pdirapply -> raise Pdirapply_should_be_expanded
| Prevapply -> raise Prevapply_should_be_expanded
- | Ploc _ -> raise Ploc_should_be_expanded
| _ -> ()
end
| _ -> ())
| Prevapply_should_be_expanded ->
Format.eprintf ">> The Prevapply primitive should never occur in an \
Flambda expression (see simplif.ml); use Apply instead"
- | Ploc_should_be_expanded ->
- Format.eprintf ">> The Ploc primitive should never occur in an \
- Flambda expression (see translcore.ml); use Apply instead"
| Move_to_a_closure_not_in_the_free_variables (start_from, move_to) ->
Format.eprintf ">> A Move_within_set_of_closures from the closure %a \
to closures that are not parts of its free variables: %a"
func_decl
end else begin
done_something := true;
- Flambda.create_function_declaration
- ~params:func_decl.params
- ~body:new_body
- ~stub:func_decl.stub
- ~dbg:func_decl.dbg
- ~inline:func_decl.inline
- ~specialise:func_decl.specialise
- ~is_a_functor:func_decl.is_a_functor
+ Flambda.update_function_declaration func_decl
+ ~params:func_decl.params ~body:new_body
end)
function_decls.funs
in
if not (body == func_decl.body) then begin
done_something := true;
end;
- Flambda.create_function_declaration
- ~params:func_decl.params
- ~body
- ~stub:func_decl.stub
- ~dbg:func_decl.dbg
- ~inline:func_decl.inline
- ~specialise:func_decl.specialise
- ~is_a_functor:func_decl.is_a_functor)
+ Flambda.update_function_declaration func_decl
+ ~params:func_decl.params ~body)
function_decls.funs
in
if not !done_something then
function_decl
else begin
done_something := true;
- Flambda.create_function_declaration ~body:new_body
- ~params:function_decl.params
- ~stub:function_decl.stub
- ~dbg:function_decl.dbg
- ~inline:function_decl.inline
- ~specialise:function_decl.specialise
- ~is_a_functor:function_decl.is_a_functor
+ Flambda.update_function_declaration function_decl
+ ~body:new_body ~params:function_decl.params
end)
set_of_closures.function_decls.funs
in
function_decl
else begin
done_something := true;
- Flambda.create_function_declaration ~body
- ~params:function_decl.params
- ~stub:function_decl.stub
- ~dbg:function_decl.dbg
- ~inline:function_decl.inline
- ~specialise:function_decl.specialise
- ~is_a_functor:function_decl.is_a_functor
+ Flambda.update_function_declaration function_decl
+ ~body ~params:function_decl.params
end)
set_of_closures.function_decls.funs
in
function_decl
else begin
done_something := true;
- Flambda.create_function_declaration ~body
- ~params:function_decl.params
- ~stub:function_decl.stub
- ~dbg:function_decl.dbg
- ~inline:function_decl.inline
- ~specialise:function_decl.specialise
- ~is_a_functor:function_decl.is_a_functor
+ Flambda.update_function_declaration function_decl
+ ~body ~params:function_decl.params
end)
set_of_closures.function_decls.funs
in
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
-let name_expr (named : Flambda.named) ~name : Flambda.t =
+let name_expr ~name (named : Flambda.named) : Flambda.t =
let var =
Variable.create
~current_compilation_unit:(Compilation_unit.get_current_exn ())
in
Flambda.create_let var named (Var var)
+let name_expr_from_var ~var (named : Flambda.named) : Flambda.t =
+ let var =
+ Variable.rename
+ ~current_compilation_unit:(Compilation_unit.get_current_exn ())
+ var
+ in
+ Flambda.create_let var named (Var var)
+
let find_declaration cf ({ funs } : Flambda.function_declarations) =
Variable.Map.find (Closure_id.unwrap cf) funs
(* CR-someday mshinwell: Fix [Flambda_iterators] so this can be implemented
properly. *)
let toplevel_substitution_named sb named =
- let expr = name_expr named ~name:"toplevel_substitution_named" in
+ let name = Internal_variable_names.toplevel_substitution_named in
+ let expr = name_expr named ~name in
match toplevel_substitution sb expr with
| Let let_expr -> let_expr.defining_expr
| _ -> assert false
-let make_closure_declaration ~id ~body ~params ~stub : Flambda.t =
+let make_closure_declaration
+ ~is_classic_mode ~id ~body ~params ~stub : Flambda.t =
let free_variables = Flambda.free_variables body in
let param_set = Parameter.Set.vars params in
if not (Variable.Set.subset param_set free_variables) then begin
Flambda.create_function_declaration ~params:(List.map subst_param params)
~body ~stub ~dbg:Debuginfo.none ~inline:Default_inline
~specialise:Default_specialise ~is_a_functor:false
+ ~closure_origin:(Closure_origin.create (Closure_id.wrap id))
in
assert (Variable.Set.equal (Variable.Set.map subst free_variables)
function_declaration.free_variables);
in
let compilation_unit = Compilation_unit.get_current_exn () in
let set_of_closures_var =
- Variable.create "set_of_closures"
+ Variable.create Internal_variable_names.set_of_closures
~current_compilation_unit:compilation_unit
in
let set_of_closures =
let function_decls =
Flambda.create_function_declarations
+ ~is_classic_mode
~funs:(Variable.Map.singleton id function_declaration)
in
Flambda.create_set_of_closures ~function_decls ~free_vars
}
in
let project_closure_var =
- Variable.create "project_closure"
+ Variable.create Internal_variable_names.project_closure
~current_compilation_unit:compilation_unit
in
Flambda.create_let set_of_closures_var (Set_of_closures set_of_closures)
{ function_decls } ->
Variable.Map.iter (fun var _ ->
let closure_id = Closure_id.wrap var in
- map := Closure_id.Map.add closure_id function_decls !map)
+ let set_of_closures_id = function_decls.set_of_closures_id in
+ map := Closure_id.Map.add closure_id set_of_closures_id !map)
function_decls.funs
in
Flambda_iterators.iter_on_set_of_closures_of_program
~f:add_set_of_closures;
!map
-let make_closure_map' input =
- let map = ref Closure_id.Map.empty in
- let add_set_of_closures _ (function_decls : Flambda.function_declarations) =
- Variable.Map.iter (fun var _ ->
- let closure_id = Closure_id.wrap var in
- map := Closure_id.Map.add closure_id function_decls !map)
- function_decls.funs
- in
- Set_of_closures_id.Map.iter add_set_of_closures input;
- !map
+let all_lifted_constant_closures program =
+ List.fold_left (fun unchanged flambda ->
+ match flambda with
+ | (_, Flambda.Set_of_closures { function_decls = { funs } }) ->
+ Variable.Map.fold
+ (fun key (_ : Flambda.function_declaration) acc ->
+ Closure_id.Set.add (Closure_id.wrap key) acc)
+ funs
+ unchanged
+ | _ -> unchanged)
+ Closure_id.Set.empty
+ (all_lifted_constants program)
let all_lifted_constant_sets_of_closures program =
let set = ref Set_of_closures_id.Set.empty in
set_of_closures !r);
!r
-let all_function_decls_indexed_by_set_of_closures_id program =
- Set_of_closures_id.Map.map
- (fun { Flambda. function_decls; _ } -> function_decls)
- (all_sets_of_closures_map program)
-
-let all_function_decls_indexed_by_closure_id program =
- let aux_fun function_decls fun_var _ map =
- let closure_id = Closure_id.wrap fun_var in
- Closure_id.Map.add closure_id function_decls map
- in
- let aux _ ({ function_decls; _ } : Flambda.set_of_closures) map =
- Variable.Map.fold (aux_fun function_decls) function_decls.funs map
- in
- Set_of_closures_id.Map.fold aux (all_sets_of_closures_map program)
- Closure_id.Map.empty
-
-let make_variable_symbol var =
- Symbol.create (Compilation_unit.get_current_exn ())
- (Linkage_name.create
- (Variable.unique_name (Variable.rename var)))
-
-let make_variables_symbol vars =
- let name =
- String.concat "_and_"
- (List.map (fun var -> Variable.unique_name (Variable.rename var)) vars)
- in
- Symbol.create (Compilation_unit.get_current_exn ()) (Linkage_name.create name)
-
let substitute_read_symbol_field_for_variables
(substitution : (Symbol.t * int list) Variable.Map.t)
(expr : Flambda.t) =
| [] -> Symbol symbol
| [i] -> Read_symbol_field (symbol, i)
| h :: t ->
- let block = Variable.create "symbol_field_block" in
- let field = Variable.create "get_symbol_field" in
+ let block_name = Internal_variable_names.symbol_field_block in
+ let block = Variable.create block_name in
+ let field_name = Internal_variable_names.get_symbol_field in
+ let field = Variable.create field_name in
Expr (
Flambda.create_let block (make_named t)
(Flambda.create_let field
lwhite: the params restriction seems odd, perhaps give a reason
in the comment. *)
val make_closure_declaration
- : id:Variable.t
+ : is_classic_mode:bool
+ -> id:Variable.t
-> body:Flambda.t
-> params:Parameter.t list
-> stub:bool
-> body:Flambda.t
-> Flambda.t
-val name_expr : Flambda.named -> name:string -> Flambda.t
+val name_expr
+ : name:Internal_variable_names.t
+ -> Flambda.named
+ -> Flambda.t
+
+val name_expr_from_var
+ : var:Variable.t
+ -> Flambda.named
+ -> Flambda.t
val compare_const : Flambda.const -> Flambda.const -> int
exception. *)
val might_raise_static_exn : Flambda.named -> Static_exception.t -> bool
-(** Creates a map from closure IDs to function declarations by iterating over
+(** Creates a map from closure IDs to set_of_closure IDs by iterating over
all sets of closures in the given program. *)
val make_closure_map
: Flambda.program
- -> Flambda.function_declarations Closure_id.Map.t
-
-(** Like [make_closure_map], but takes a mapping from set of closures IDs to
- function declarations, instead of a [program]. *)
-val make_closure_map'
- : Flambda.function_declarations Set_of_closures_id.Map.t
- -> Flambda.function_declarations Closure_id.Map.t
+ -> Set_of_closures_id.t Closure_id.Map.t
(** The definitions of all constants that have been lifted out to [Let_symbol]
or [Let_rec_symbol] constructions. *)
: Flambda.program
-> Set_of_closures_id.Set.t
+val all_lifted_constant_closures : Flambda.program -> Closure_id.Set.t
+
(** All sets of closures in the given program (whether or not bound to a
symbol.) *)
val all_sets_of_closures : Flambda.program -> Flambda.set_of_closures list
: Flambda.program
-> Flambda.set_of_closures Set_of_closures_id.Map.t
-val all_function_decls_indexed_by_set_of_closures_id
- : Flambda.program
- -> Flambda.function_declarations Set_of_closures_id.Map.t
-
-val all_function_decls_indexed_by_closure_id
- : Flambda.program
- -> Flambda.function_declarations Closure_id.Map.t
-
-val make_variable_symbol : Variable.t -> Symbol.t
-val make_variables_symbol : Variable.t list -> Symbol.t
(* CR-someday pchambart: A more general version of this function might
take a [named] instead of a symbol and be called with
(** For the compilation of switch statements. *)
module Switch_storer : sig
- val mk_store : unit -> Flambda.t Switch.t_store
+ val mk_store : unit -> (Flambda.t, unit) Switch.t_store
end
(** Within a set of function declarations there is a set of function bodies,
id' :: ids, t) ids ([], t)
let active_add_mutable_variable t id =
- let id' = Mutable_variable.freshen id in
+ let id' = Mutable_variable.rename id in
let t = add_sb_mutable_var t id id' in
id', t
| Inactive -> function_declarations
| Active _ ->
let all_free_symbols =
- Flambda_utils.all_free_symbols function_declarations
+ Variable.Map.fold
+ (fun _ (function_decl : Flambda.function_declaration)
+ syms ->
+ Symbol.Set.union syms function_decl.free_symbols)
+ function_declarations.funs Symbol.Set.empty
in
let closure_symbols_used = ref false in
let closure_symbols =
| e -> e)
ffun.body
in
- Flambda.create_function_declaration ~params:ffun.params
- ~body ~stub:ffun.stub ~dbg:ffun.dbg ~inline:ffun.inline
- ~specialise:ffun.specialise ~is_a_functor:ffun.is_a_functor)
+ Flambda.update_body_of_function_declaration ffun ~body)
function_declarations.funs
in
Flambda.update_function_declarations function_declarations ~funs
Flambda_utils.toplevel_substitution subst.sb_var func_decl.body
in
let function_decl =
- Flambda.create_function_declaration ~params
- ~body ~stub:func_decl.stub ~dbg:func_decl.dbg
+ Flambda.create_function_declaration ~params ~body
+ ~stub:func_decl.stub ~dbg:func_decl.dbg
~inline:func_decl.inline ~specialise:func_decl.specialise
~is_a_functor:func_decl.is_a_functor
+ ~closure_origin:func_decl.closure_origin
in
function_decl, subst
in
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+val constant_field
+ : Flambda.t
+ -> Flambda.constant_defining_value_block_field option
+
(** Transform Initialize_symbol with only constant fields to
let_symbol construction. *)
val run : Flambda.program -> Flambda.program
in
let body =
match body with
- | Is_named body -> Flambda_utils.name_expr body ~name:"simplify_fv"
+ | Is_named body ->
+ let name = Internal_variable_names.simplify_fv in
+ Flambda_utils.name_expr body ~name
| Is_expr body -> body
in
Is_expr (W.create_let_reusing_defining_expr var named body), r
| Some _ | None ->
match set_of_closures_symbol with
| Some set_of_closures_symbol ->
- let set_of_closures_var = Variable.create "symbol" in
+ let set_of_closures_var =
+ Variable.create Internal_variable_names.symbol
+ in
let project_closure : Flambda.project_closure =
{ set_of_closures = set_of_closures_var;
closure_id = move_to;
}
in
- let project_closure_var = Variable.create "project_closure" in
+ let project_closure_var =
+ Variable.create Internal_variable_names.project_closure
+ in
let let1 =
Flambda.create_let project_closure_var
(Project_closure project_closure)
~inline_inside:
(Inlining_decision.should_inline_inside_declaration function_decl)
~dbg:function_decl.dbg
- ~f:(fun body_env -> simplify body_env r function_decl.body)
- in
- let inline : Lambda.inline_attribute =
- match function_decl.inline with
- | Default_inline ->
- if !Clflags.classic_inlining && not function_decl.stub then
- (* In classic-inlining mode, the inlining decision is taken at
- definition site (here). If the function is small enough
- (below the -inline threshold) it will always be inlined. *)
- let inlining_threshold =
- Inline_and_simplify_aux.initial_inlining_threshold
- ~round:(E.round env)
- in
- if Inlining_cost.can_inline body inlining_threshold ~bonus:0
- then
- Always_inline
- else
- Default_inline
- else
- Default_inline
- | inline ->
- inline
+ ~f:(fun body_env ->
+ assert (E.inside_set_of_closures_declaration
+ function_decls.set_of_closures_origin body_env);
+ simplify body_env r function_decl.body)
in
let function_decl =
Flambda.create_function_declaration ~params:function_decl.params
~body ~stub:function_decl.stub ~dbg:function_decl.dbg
- ~inline ~specialise:function_decl.specialise
+ ~inline:function_decl.inline ~specialise:function_decl.specialise
~is_a_functor:function_decl.is_a_functor
+ ~closure_origin:function_decl.closure_origin
in
let used_params' = Flambda.used_params function_decl in
Variable.Map.add fun_var function_decl funs,
lazy (Invariant_params.invariant_params_in_recursion function_decls
~backend:(E.backend env))
in
+ let recursive =
+ lazy (Find_recursive_functions.in_function_declarations function_decls
+ ~backend:(E.backend env))
+ in
+ let keep_body =
+ Inline_and_simplify_aux.keep_body_check
+ ~is_classic_mode:function_decls.is_classic_mode ~recursive
+ in
+ let function_decls_approx =
+ A.function_declarations_approx ~keep_body function_decls
+ in
let value_set_of_closures =
- A.create_value_set_of_closures ~function_decls
+ A.create_value_set_of_closures
+ ~function_decls:function_decls_approx
~bound_vars:internal_value_set_of_closures.bound_vars
~invariant_params
+ ~recursive
~specialised_args:internal_value_set_of_closures.specialised_args
+ ~free_vars:internal_value_set_of_closures.free_vars
~freshening:internal_value_set_of_closures.freshening
~direct_call_surrogates:
internal_value_set_of_closures.direct_call_surrogates
| surrogate -> find_transitively surrogate
in
let surrogate = find_transitively surrogate in
- let surrogate_var =
- Variable.rename lhs_of_application ~append:"_surrogate"
- in
+ let surrogate_var = Variable.rename lhs_of_application in
let move_to_surrogate : Projection.move_within_set_of_closures =
{ closure = lhs_of_application;
start_from = closure_id_being_applied;
let function_decls = value_set_of_closures.function_decls in
let function_decl =
try
- Flambda_utils.find_declaration closure_id_being_applied
- function_decls
+ Variable.Map.find
+ (Closure_id.unwrap closure_id_being_applied)
+ function_decls.funs
with
| Not_found ->
Misc.fatal_errorf "When handling application expression, \
| Direct _ -> r
in
let nargs = List.length args in
- let arity = Flambda_utils.function_arity function_decl in
+ let arity = A.function_arity function_decl in
let result, r =
if nargs = arity then
simplify_full_application env r ~function_decls
and simplify_partial_application env r ~lhs_of_application
~closure_id_being_applied ~function_decl ~args ~dbg
~inline_requested ~specialise_requested =
- let arity = Flambda_utils.function_arity function_decl in
+ let arity = A.function_arity function_decl in
assert (arity > List.length args);
(* For simplicity, we disallow [@inline] attributes on partial
applications. The user may always write an explicit wrapper instead
| Default_specialise -> ()
end;
let freshened_params =
- List.map (fun p -> Parameter.rename p) function_decl.Flambda.params
+ List.map (fun p -> Parameter.rename p) function_decl.A.params
in
let applied_args, remaining_args =
Misc.Stdlib.List.map2_prefix (fun arg id' -> id', arg)
in
let closure_variable =
Variable.rename
- ~append:"_partial_fun"
(Closure_id.unwrap closure_id_being_applied)
in
Flambda_utils.make_closure_declaration ~id:closure_variable
+ ~is_classic_mode:false
~body
~params:remaining_args
~stub:true
and simplify_over_application env r ~args ~args_approxs ~function_decls
~lhs_of_application ~closure_id_being_applied ~function_decl
~value_set_of_closures ~dbg ~inline_requested ~specialise_requested =
- let arity = Flambda_utils.function_arity function_decl in
+ let arity = A.function_arity function_decl in
assert (arity < List.length args);
assert (List.length args = List.length args_approxs);
let full_app_args, remaining_args =
~args:full_app_args ~args_approxs:full_app_approxs ~dbg
~inline_requested ~specialise_requested
in
- let func_var = Variable.create "full_apply" in
+ let func_var = Variable.create Internal_variable_names.full_apply in
let expr : Flambda.t =
Flambda.create_let func_var (Expr expr)
(Apply { func = func_var; args = remaining_args; kind = Indirect; dbg;
| Some set_of_closures ->
let expr =
Flambda_utils.name_expr (Set_of_closures set_of_closures)
- ~name:"remove_unused_arguments"
+ ~name:Internal_variable_names.remove_unused_arguments
in
simplify env r expr ~pass_name:"Remove_unused_arguments"
| None ->
else h' :: t', approxs, r
and duplicate_function ~env ~(set_of_closures : Flambda.set_of_closures)
- ~fun_var =
+ ~fun_var ~new_fun_var =
let function_decl =
match Variable.Map.find fun_var set_of_closures.function_decls.funs with
| exception Not_found ->
~inline_inside:false
~dbg:function_decl.dbg
~f:(fun body_env ->
+ assert (E.inside_set_of_closures_declaration
+ function_decls.set_of_closures_origin body_env);
simplify body_env (R.create ()) function_decl.body)
in
let function_decl =
~body ~stub:function_decl.stub ~dbg:function_decl.dbg
~inline:function_decl.inline ~specialise:function_decl.specialise
~is_a_functor:function_decl.is_a_functor
+ ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var))
in
function_decl, specialised_args
lazy (Invariant_params.invariant_params_in_recursion function_decls
~backend:(E.backend env))
in
+ let recursive =
+ lazy (Find_recursive_functions.in_function_declarations function_decls
+ ~backend:(E.backend env))
+ in
let value_set_of_closures =
+ let keep_body =
+ Inline_and_simplify_aux.keep_body_check
+ ~is_classic_mode:function_decls.is_classic_mode ~recursive
+ in
+ let function_decls =
+ A.function_declarations_approx ~keep_body function_decls
+ in
A.create_value_set_of_closures ~function_decls
~bound_vars:Var_within_closure.Map.empty
~invariant_params
+ ~recursive
~specialised_args:Variable.Map.empty
+ ~free_vars:Variable.Map.empty
~freshening:Freshening.Project_var.empty
~direct_call_surrogates:Closure_id.Map.empty
in
end
(* See documentation on [Let_rec_symbol] in flambda.mli. *)
-let define_let_rec_symbol_approx env defs =
+let define_let_rec_symbol_approx orig_env defs =
(* First declare an empty version of the symbols *)
- let env =
- List.fold_left (fun env (symbol, _) ->
- E.add_symbol env symbol (A.value_unresolved (Symbol symbol)))
- env defs
+ let init_env =
+ List.fold_left (fun building_env (symbol, _) ->
+ E.add_symbol building_env symbol (A.value_unresolved (Symbol symbol)))
+ orig_env defs
in
- let rec loop times env =
+ let rec loop times lookup_env =
if times <= 0 then
- env
+ lookup_env
else
let env =
- List.fold_left (fun newenv (symbol, constant_defining_value) ->
+ List.fold_left (fun building_env (symbol, constant_defining_value) ->
let approx =
- constant_defining_value_approx env constant_defining_value
+ constant_defining_value_approx lookup_env constant_defining_value
in
let approx = A.augment_with_symbol approx symbol in
- E.redefine_symbol newenv symbol approx)
- env defs
+ E.add_symbol building_env symbol approx)
+ orig_env defs
in
loop (times-1) env
in
- loop 2 env
+ loop 2 init_env
let simplify_constant_defining_value
env r symbol
: Flambda.program_body * R.t =
match program with
| Let_rec_symbol (defs, program) ->
- let env = define_let_rec_symbol_approx env defs in
- let env, r, defs =
- List.fold_left (fun (newenv, r, defs) (symbol, def) ->
- let r, def, approx =
- simplify_constant_defining_value env r symbol def
- in
- let approx = A.augment_with_symbol approx symbol in
- let newenv = E.redefine_symbol newenv symbol approx in
- (newenv, r, (symbol, def) :: defs))
+ let set_of_closures_defs, other_defs =
+ List.partition
+ (function
+ | (_, Flambda.Set_of_closures _) -> true
+ | _ -> false)
+ defs in
+ let process_defs ~lookup_env ~env r defs =
+ List.fold_left (fun (building_env, r, defs) (symbol, def) ->
+ let r, def, approx =
+ simplify_constant_defining_value lookup_env r symbol def
+ in
+ let approx = A.augment_with_symbol approx symbol in
+ let building_env = E.add_symbol building_env symbol approx in
+ (building_env, r, (symbol, def) :: defs))
(env, r, []) defs
in
+ let env, r, set_of_closures_defs =
+ let lookup_env = define_let_rec_symbol_approx env defs in
+ process_defs ~lookup_env ~env r set_of_closures_defs
+ in
+ let env, r, other_defs =
+ let lookup_env = define_let_rec_symbol_approx env other_defs in
+ process_defs ~lookup_env ~env r other_defs
+ in
let program, r = simplify_program_body env r program in
- Let_rec_symbol (defs, program), r
+ Let_rec_symbol (set_of_closures_defs @ other_defs, program), r
| Let_symbol (symbol, constant_defining_value, program) ->
let r, constant_defining_value, approx =
simplify_constant_defining_value env r symbol constant_defining_value
: env:Inline_and_simplify_aux.Env.t
-> set_of_closures:Flambda.set_of_closures
-> fun_var:Variable.t
+ -> new_fun_var:Variable.t
-> Flambda.function_declaration
* Flambda.specialised_to Variable.Map.t (* new specialised arguments *)
never_inline_inside_closures : bool;
never_inline_outside_closures : bool;
unroll_counts : int Set_of_closures_origin.Map.t;
- inlining_counts : int Closure_id.Map.t;
+ inlining_counts : int Closure_origin.Map.t;
actively_unrolling : int Set_of_closures_origin.Map.t;
closure_depth : int;
inlining_stats_closure_stack : Inlining_stats.Closure_stack.t;
never_inline_inside_closures = false;
never_inline_outside_closures = false;
unroll_counts = Set_of_closures_origin.Map.empty;
- inlining_counts = Closure_id.Map.empty;
+ inlining_counts = Closure_origin.Map.empty;
actively_unrolling = Set_of_closures_origin.Map.empty;
closure_depth = 0;
inlining_stats_closure_stack =
let activate_freshening t =
{ t with freshening = Freshening.activate t.freshening }
- let enter_set_of_closures_declaration origin t =
+ let enter_set_of_closures_declaration t origin =
{ t with
current_functions =
Set_of_closures_origin.Set.add origin t.current_functions; }
let inlining_allowed t id =
let inlining_count =
try
- Closure_id.Map.find id t.inlining_counts
+ Closure_origin.Map.find id t.inlining_counts
with Not_found ->
max 1 (Clflags.Int_arg_helper.get
~key:t.round !Clflags.inline_max_unroll)
let inside_inlined_function t id =
let inlining_count =
try
- Closure_id.Map.find id t.inlining_counts
+ Closure_origin.Map.find id t.inlining_counts
with Not_found ->
max 1 (Clflags.Int_arg_helper.get
~key:t.round !Clflags.inline_max_unroll)
in
let inlining_counts =
- Closure_id.Map.add id (inlining_count - 1) t.inlining_counts
+ Closure_origin.Map.add id (inlining_count - 1) t.inlining_counts
in
{ t with inlining_counts }
module A = Simple_value_approx
module E = Env
+let keep_body_check ~is_classic_mode ~recursive =
+ if not is_classic_mode then begin
+ fun _ _ -> true
+ end else begin
+ let can_inline_non_rec_function (fun_decl : Flambda.function_declaration) =
+ (* In classic-inlining mode, the inlining decision is taken at
+ definition site (here). If the function is small enough
+ (below the -inline threshold) it will always be inlined.
+
+ Closure gives a bonus of [8] to optional arguments. In classic
+ mode, however, we would inline functions with the "*opt*" argument
+ in all cases, as it is a stub. (This is ensured by
+ [middle_end/closure_conversion.ml]).
+ *)
+ let inlining_threshold = initial_inlining_threshold ~round:0 in
+ let bonus = Flambda_utils.function_arity fun_decl in
+ Inlining_cost.can_inline fun_decl.body inlining_threshold ~bonus
+ in
+ fun (var : Variable.t) (fun_decl : Flambda.function_declaration) ->
+ if fun_decl.stub then begin
+ true
+ end else if Variable.Set.mem var (Lazy.force recursive) then begin
+ false
+ end else begin
+ match fun_decl.inline with
+ | Default_inline -> can_inline_non_rec_function fun_decl
+ | Unroll factor -> factor > 0
+ | Always_inline -> true
+ | Never_inline -> false
+ end
+ end
+
let prepare_to_simplify_set_of_closures ~env
~(set_of_closures : Flambda.set_of_closures)
~function_decls ~freshen
Closure_id.Map.empty
in
let env =
- E.enter_set_of_closures_declaration
- function_decls.set_of_closures_origin env
+ E.enter_set_of_closures_declaration env
+ function_decls.set_of_closures_origin
in
(* we use the previous closure for evaluating the functions *)
let internal_value_set_of_closures =
Var_within_closure.Map.add (Var_within_closure.wrap id) desc map)
free_vars Var_within_closure.Map.empty
in
+ let free_vars = Variable.Map.map fst free_vars in
+ let invariant_params = lazy Variable.Map.empty in
+ let recursive = lazy (Variable.Map.keys function_decls.funs) in
+ let is_classic_mode = function_decls.is_classic_mode in
+ let keep_body = keep_body_check ~is_classic_mode ~recursive in
+ let function_decls =
+ A.function_declarations_approx ~keep_body function_decls
+ in
A.create_value_set_of_closures ~function_decls ~bound_vars
- ~invariant_params:(lazy Variable.Map.empty) ~specialised_args
+ ~free_vars ~invariant_params ~recursive ~specialised_args
~freshening ~direct_call_surrogates
in
(* Populate the environment with the approximation of each closure.
variables from outer scopes that are not accessible. *)
val local : t -> t
- (** Note that the inliner is descending into a function body from the given
- set of closures. A set of such descents is maintained. *)
- (* CR-someday mshinwell: consider changing name to remove "declaration".
- Also, isn't this the inlining stack? Maybe we can use that instead. *)
- val enter_set_of_closures_declaration : Set_of_closures_origin.t -> t -> t
-
(** Determine whether the inliner is currently inside a function body from
the given set of closures. This is used to detect whether a given
function call refers to a function which exists somewhere on the current
(** Whether it is permissible to inline a call to a function in the given
environment. *)
- val inlining_allowed : t -> Closure_id.t -> bool
+ val inlining_allowed : t -> Closure_origin.t -> bool
(** Whether the given environment is currently being used to rewrite the
body of an inlined function. *)
- val inside_inlined_function : t -> Closure_id.t -> t
+ val inside_inlined_function : t -> Closure_origin.t -> t
(** If collecting inlining statistics, record that the inliner is about to
descend into [closure_id]. This information enables us to produce a
-> parameter_approximations:Simple_value_approx.t Variable.Map.t
-> set_of_closures_env:Env.t
-> Env.t
+
+val keep_body_check
+ : is_classic_mode:bool
+ -> recursive:Variable.Set.t Lazy.t
+ -> Variable.t
+ -> Flambda.function_declaration
+ -> bool
| Parrayrefs _ -> 8
| Parraysets Pgenarray -> 22
| Parraysets _ -> 10
- | Pbittest -> 3
| Pbigarrayref (_, ndims, _, _) -> 4 + ndims * 6
| Pbigarrayset (_, ndims, _, _) -> 4 + ndims * 6
| Psequand | Psequor ->
module A = Simple_value_approx
module E = Inline_and_simplify_aux.Env
module R = Inline_and_simplify_aux.Result
-module U = Flambda_utils
module W = Inlining_cost.Whether_sufficient_benefit
module T = Inlining_cost.Threshold
module S = Inlining_stats_types
module D = S.Decision
+let get_function_body (function_decl : A.function_declaration) =
+ match function_decl.function_body with
+ | None -> assert false
+ | Some function_body -> function_body
+
type ('a, 'b) inlining_result =
| Changed of (Flambda.t * R.t) * 'a
| Original of 'b
| Don't_try_it of 'b
let inline env r ~lhs_of_application
- ~(function_decls : Flambda.function_declarations)
- ~closure_id_being_applied ~(function_decl : Flambda.function_declaration)
+ ~closure_id_being_applied
+ ~(function_decl : A.function_declaration)
+ ~(function_body : A.function_body)
~value_set_of_closures ~only_use_of_function ~original ~recursive
~(args : Variable.t list) ~size_from_approximation ~dbg ~simplify
~(inline_requested : Lambda.inline_attribute)
~(specialise_requested : Lambda.specialise_attribute)
+ ~fun_vars ~set_of_closures_origin
~self_call ~fun_cost ~inlining_threshold =
let toplevel = E.at_toplevel env in
let branch_depth = E.branch_depth env in
let unrolling, always_inline, never_inline, env =
- let unrolling =
- E.actively_unrolling env function_decls.set_of_closures_origin
- in
+ let unrolling = E.actively_unrolling env set_of_closures_origin in
match unrolling with
| Some count ->
if count > 0 then
- let env =
- E.continue_actively_unrolling
- env function_decls.set_of_closures_origin
- in
+ let env = E.continue_actively_unrolling env set_of_closures_origin in
true, true, false, env
else false, false, true, env
| None -> begin
The call site annotation takes precedence *)
match (inline_requested : Lambda.inline_attribute) with
| Always_inline | Never_inline | Unroll _ -> inline_requested
- | Default_inline -> function_decl.inline
+ | Default_inline -> function_body.inline
in
match inline_annotation with
| Always_inline -> false, true, false, env
if count > 0 then
let env =
E.start_actively_unrolling
- env function_decls.set_of_closures_origin (count - 1)
+ env set_of_closures_origin (count - 1)
in
true, true, false, env
else false, false, true, env
Try_it
else if self_call then
Don't_try_it S.Not_inlined.Self_call
- else if not (E.inlining_allowed env closure_id_being_applied) then
+ else if not (E.inlining_allowed env function_decl.closure_origin) then
Don't_try_it S.Not_inlined.Unrolling_depth_exceeded
else if only_use_of_function || always_inline then
Try_it
else if never_inline then
Don't_try_it S.Not_inlined.Annotation
- else if !Clflags.classic_inlining then
- Don't_try_it S.Not_inlined.Classic_mode
- else if not (E.unrolling_allowed env function_decls.set_of_closures_origin)
+ else if not (E.unrolling_allowed env set_of_closures_origin)
&& (Lazy.force recursive) then
Don't_try_it S.Not_inlined.Unrolling_depth_exceeded
else if remaining_inlining_threshold = T.Never_inline then
else acc
| None -> acc
with Not_found -> acc)
- function_decl.free_variables benefit
+ function_body.free_variables benefit
in
W.create_estimate
~original_size:Inlining_cost.direct_call_size
~new_size:body_size
~toplevel:(E.at_toplevel env)
~branch_depth:(E.branch_depth env)
- ~lifting:function_decl.Flambda.is_a_functor
+ ~lifting:function_body.A.is_a_functor
~round:(E.round env)
~benefit
in
the function, without doing any further inlining upon it, to the call
site. *)
Inlining_transforms.inline_by_copying_function_body ~env
- ~r:(R.reset_benefit r) ~function_decls ~lhs_of_application
+ ~r:(R.reset_benefit r) ~lhs_of_application
~closure_id_being_applied ~specialise_requested ~inline_requested
- ~function_decl ~args ~dbg ~simplify
+ ~function_decl ~function_body ~fun_vars ~args ~dbg ~simplify
in
let num_direct_applications_seen =
(R.num_direct_applications r_inlined) - (R.num_direct_applications r)
let env =
(* We decrement the unrolling count even if the function is not
recursive to avoid having to check whether or not it is recursive *)
- E.inside_unrolled_function env function_decls.set_of_closures_origin
+ E.inside_unrolled_function env set_of_closures_origin
in
- let env = E.inside_inlined_function env closure_id_being_applied in
+ let env = E.inside_inlined_function env function_decl.closure_origin in
let env =
if E.inlining_level env = 0
(* If the function was considered for inlining without considering
W.create ~original body
~toplevel:(E.at_toplevel env)
~branch_depth:(E.branch_depth env)
- ~lifting:function_decl.Flambda.is_a_functor
+ ~lifting:function_body.is_a_functor
~round:(E.round env)
~benefit:(R.benefit r_inlined)
in
let env =
(* We decrement the unrolling count even if the function is recursive
to avoid having to check whether or not it is recursive *)
- E.inside_unrolled_function env function_decls.set_of_closures_origin
+ E.inside_unrolled_function env set_of_closures_origin
in
let body, r_inlined = simplify env r_inlined body in
let wsb_with_subfunctions =
W.create ~original body
~toplevel:(E.at_toplevel env)
~branch_depth:(E.branch_depth env)
- ~lifting:function_decl.Flambda.is_a_functor
+ ~lifting:function_body.is_a_functor
~round:(E.round env)
~benefit:(R.benefit r_inlined)
in
end
let specialise env r ~lhs_of_application
- ~(function_decls : Flambda.function_declarations)
- ~(function_decl : Flambda.function_declaration)
+ ~(function_decls : A.function_declarations)
+ ~(function_decl : A.function_declaration)
~closure_id_being_applied
- ~(value_set_of_closures : Simple_value_approx.value_set_of_closures)
+ ~(value_set_of_closures : A.value_set_of_closures)
~args ~args_approxs ~dbg ~simplify ~original ~recursive ~self_call
~inlining_threshold ~fun_cost
~inline_requested ~specialise_requested =
- let bound_vars =
- lazy
- (let closures_required =
- Flambda_utils.closures_required_by_entry_point
- ~entry_point:closure_id_being_applied
- ~backend:(E.backend env)
- function_decls
- in
- let bound_vars_required =
- Variable.Set.fold (fun fun_var bound_vars_required ->
- let bound_vars =
- Flambda_utils.variables_bound_by_the_closure
- (Closure_id.wrap fun_var)
- function_decls
- in
- Variable.Set.union bound_vars bound_vars_required)
- closures_required
- Variable.Set.empty
- in
- Var_within_closure.Map.filter (fun var _approx ->
- Variable.Set.mem (Var_within_closure.unwrap var) bound_vars_required)
- value_set_of_closures.bound_vars)
- in
let invariant_params = value_set_of_closures.invariant_params in
+ let free_vars = value_set_of_closures.free_vars in
let has_no_useful_approxes =
lazy
(List.for_all2
| Always_specialise -> true, false
| Never_specialise -> false, true
| Default_specialise -> begin
- match (function_decl.specialise : Lambda.specialise_attribute) with
- | Always_specialise -> true, false
- | Never_specialise -> false, true
- | Default_specialise -> false, false
+ match function_decl.function_body with
+ | None -> false, true
+ | Some { specialise } ->
+ match (specialise : Lambda.specialise_attribute) with
+ | Always_specialise -> true, false
+ | Never_specialise -> false, true
+ | Default_specialise -> false, false
end
in
let remaining_inlining_threshold : Inlining_cost.Threshold.t =
- is closed (it and all other members of the set of closures on which
it depends); and
- has useful approximations for some invariant parameters. *)
- if !Clflags.classic_inlining then
+ if function_decls.is_classic_mode then
Don't_try_it S.Not_specialised.Classic_mode
else if self_call then
Don't_try_it S.Not_specialised.Self_call
| T.Can_inline_if_no_larger_than threshold -> threshold
in
Don't_try_it (S.Not_specialised.Above_threshold threshold)
- else if not (Var_within_closure.Map.is_empty (Lazy.force bound_vars)) then
+ else if not (Variable.Map.is_empty free_vars) then
Don't_try_it S.Not_specialised.Not_closed
else if not (Lazy.force recursive) then
Don't_try_it S.Not_specialised.Not_recursive
~r:(R.reset_benefit r) ~lhs_of_application
~function_decls ~closure_id_being_applied ~function_decl
~args ~args_approxs
- ~invariant_params:value_set_of_closures.invariant_params
+ ~invariant_params:invariant_params
~specialised_args:value_set_of_closures.specialised_args
+ ~free_vars:value_set_of_closures.free_vars
~direct_call_surrogates:value_set_of_closures.direct_call_surrogates
~dbg ~simplify ~inline_requested
in
Original decision
end
-let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations)
+let for_call_site ~env ~r ~(function_decls : A.function_declarations)
~lhs_of_application ~closure_id_being_applied
- ~(function_decl : Flambda.function_declaration)
- ~(value_set_of_closures : Simple_value_approx.value_set_of_closures)
+ ~(function_decl : A.function_declaration)
+ ~(value_set_of_closures : A.value_set_of_closures)
~args ~args_approxs ~dbg ~simplify ~inline_requested
~specialise_requested =
if List.length args <> List.length args_approxs then begin
let original_r =
R.set_approx (R.seen_direct_application r) (A.value_unknown Other)
in
- if function_decl.stub then
- let body, r =
- Inlining_transforms.inline_by_copying_function_body ~env
- ~r ~function_decls ~lhs_of_application
- ~closure_id_being_applied ~specialise_requested ~inline_requested
- ~function_decl ~args ~dbg ~simplify
- in
- simplify env r body
- else if E.never_inline env then
- (* This case only occurs when examining the body of a stub function
- but not in the context of inlining said function. As such, there
- is nothing to do here (and no decision to report). *)
- original, original_r
- else begin
- let env = E.unset_never_inline_inside_closures env in
- let env =
- E.note_entering_call env
- ~closure_id:closure_id_being_applied ~dbg:dbg
- in
- let max_level =
- Clflags.Int_arg_helper.get ~key:(E.round env) !Clflags.inline_max_depth
- in
- let raw_inlining_threshold = R.inlining_threshold r in
- let max_inlining_threshold =
- if E.at_toplevel env then
- Inline_and_simplify_aux.initial_inlining_toplevel_threshold
- ~round:(E.round env)
- else
- Inline_and_simplify_aux.initial_inlining_threshold ~round:(E.round env)
- in
- let unthrottled_inlining_threshold =
- match raw_inlining_threshold with
- | None -> max_inlining_threshold
- | Some inlining_threshold -> inlining_threshold
- in
- let inlining_threshold =
- T.min unthrottled_inlining_threshold max_inlining_threshold
- in
- let inlining_threshold_diff =
- T.sub unthrottled_inlining_threshold inlining_threshold
- in
- let inlining_prevented =
- match inlining_threshold with
- | Never_inline -> true
- | Can_inline_if_no_larger_than _ -> false
- in
- let simpl =
- if inlining_prevented then
- Original (D.Prevented Function_prevented_from_inlining)
- else if E.inlining_level env >= max_level then
- Original (D.Prevented Level_exceeded)
- else begin
- let self_call =
- E.inside_set_of_closures_declaration
- function_decls.set_of_closures_origin env
- in
- let fun_cost =
- lazy
- (Inlining_cost.can_try_inlining function_decl.body
- inlining_threshold
- ~number_of_arguments:(List.length function_decl.params)
- (* CR-someday mshinwell: for the moment, this is None, since
- the Inlining_cost code isn't checking sizes up to the max
- inlining threshold---this seems to take too long. *)
- ~size_from_approximation:None)
- in
- let fun_var =
- U.find_declaration_variable closure_id_being_applied function_decls
- in
- let recursive =
- lazy
- (Variable.Set.mem fun_var
- ((Find_recursive_functions.in_function_declarations
- function_decls
- ~backend:(E.backend env))))
- in
- let specialise_result =
- specialise env r ~lhs_of_application ~function_decls ~recursive
- ~closure_id_being_applied ~function_decl ~value_set_of_closures
- ~args ~args_approxs ~dbg ~simplify ~original ~inline_requested
- ~specialise_requested ~fun_cost ~self_call ~inlining_threshold
- in
- match specialise_result with
- | Changed (res, spec_reason) ->
- Changed (res, D.Specialised spec_reason)
- | Original spec_reason ->
- let only_use_of_function = false in
- (* If we didn't specialise then try inlining *)
- let size_from_approximation =
- match
- Variable.Map.find fun_var (Lazy.force value_set_of_closures.size)
- with
- | size -> size
- | exception Not_found ->
+ match function_decl.function_body with
+ | None -> original, original_r
+ | Some { stub; _ } ->
+ if stub then begin
+ let fun_vars = Variable.Map.keys function_decls.funs in
+ let function_body = get_function_body function_decl in
+ let body, r =
+ Inlining_transforms.inline_by_copying_function_body ~env
+ ~r ~fun_vars ~lhs_of_application
+ ~closure_id_being_applied ~specialise_requested ~inline_requested
+ ~function_decl ~function_body ~args ~dbg ~simplify
+ in
+ simplify env r body
+ end else if E.never_inline env then
+ (* This case only occurs when examining the body of a stub function
+ but not in the context of inlining said function. As such, there
+ is nothing to do here (and no decision to report). *)
+ original, original_r
+ else if function_decls.is_classic_mode then begin
+ let env =
+ E.note_entering_call env
+ ~closure_id:closure_id_being_applied ~dbg:dbg
+ in
+ let simpl =
+ match function_decl.function_body with
+ | None -> Original S.Not_inlined.Classic_mode
+ | Some function_body ->
+ let self_call =
+ E.inside_set_of_closures_declaration
+ function_decls.set_of_closures_origin env
+ in
+ let try_inlining =
+ if self_call then
+ Don't_try_it S.Not_inlined.Self_call
+ else if not (E.inlining_allowed env function_decl.closure_origin) then
+ Don't_try_it S.Not_inlined.Unrolling_depth_exceeded
+ else
+ Try_it
+ in
+ match try_inlining with
+ | Don't_try_it decision -> Original decision
+ | Try_it ->
+ let fun_vars = Variable.Map.keys function_decls.funs in
+ let body, r =
+ Inlining_transforms.inline_by_copying_function_body ~env
+ ~r ~function_body ~lhs_of_application
+ ~closure_id_being_applied ~specialise_requested ~inline_requested
+ ~function_decl ~fun_vars ~args ~dbg ~simplify
+ in
+ let env = E.note_entering_inlined env in
+ let env =
+ (* We decrement the unrolling count even if the function is not
+ recursive to avoid having to check whether or not it is
+ recursive *)
+ E.inside_unrolled_function env function_decls.set_of_closures_origin
+ in
+ let env = E.inside_inlined_function env function_decl.closure_origin in
+ Changed ((simplify env r body), S.Inlined.Classic_mode)
+ in
+ let res, decision =
+ match simpl with
+ | Original decision ->
+ let decision =
+ S.Decision.Unchanged (S.Not_specialised.Classic_mode, decision)
+ in
+ (original, original_r), decision
+ | Changed ((expr, r), decision) ->
+ let max_inlining_threshold =
+ if E.at_toplevel env then
+ Inline_and_simplify_aux.initial_inlining_toplevel_threshold
+ ~round:(E.round env)
+ else
+ Inline_and_simplify_aux.initial_inlining_threshold
+ ~round:(E.round env)
+ in
+ let raw_inlining_threshold = R.inlining_threshold r in
+ let unthrottled_inlining_threshold =
+ match raw_inlining_threshold with
+ | None -> max_inlining_threshold
+ | Some inlining_threshold -> inlining_threshold
+ in
+ let inlining_threshold =
+ T.min unthrottled_inlining_threshold max_inlining_threshold
+ in
+ let inlining_threshold_diff =
+ T.sub unthrottled_inlining_threshold inlining_threshold
+ in
+ let res =
+ if E.inlining_level env = 0
+ then expr, R.set_inlining_threshold r raw_inlining_threshold
+ else expr, R.add_inlining_threshold r inlining_threshold_diff
+ in
+ res, S.Decision.Inlined (S.Not_specialised.Classic_mode, decision)
+ in
+ E.record_decision env decision;
+ res
+ end else begin
+ let function_body = get_function_body function_decl in
+ let env = E.unset_never_inline_inside_closures env in
+ let env =
+ E.note_entering_call env
+ ~closure_id:closure_id_being_applied ~dbg:dbg
+ in
+ let max_level =
+ Clflags.Int_arg_helper.get ~key:(E.round env) !Clflags.inline_max_depth
+ in
+ let raw_inlining_threshold = R.inlining_threshold r in
+ let max_inlining_threshold =
+ if E.at_toplevel env then
+ Inline_and_simplify_aux.initial_inlining_toplevel_threshold
+ ~round:(E.round env)
+ else
+ Inline_and_simplify_aux.initial_inlining_threshold ~round:(E.round env)
+ in
+ let unthrottled_inlining_threshold =
+ match raw_inlining_threshold with
+ | None -> max_inlining_threshold
+ | Some inlining_threshold -> inlining_threshold
+ in
+ let inlining_threshold =
+ T.min unthrottled_inlining_threshold max_inlining_threshold
+ in
+ let inlining_threshold_diff =
+ T.sub unthrottled_inlining_threshold inlining_threshold
+ in
+ let inlining_prevented =
+ match inlining_threshold with
+ | Never_inline -> true
+ | Can_inline_if_no_larger_than _ -> false
+ in
+ let simpl =
+ if inlining_prevented then
+ Original (D.Prevented Function_prevented_from_inlining)
+ else if E.inlining_level env >= max_level then
+ Original (D.Prevented Level_exceeded)
+ else begin
+ let self_call =
+ E.inside_set_of_closures_declaration
+ function_decls.set_of_closures_origin env
+ in
+ let fun_cost =
+ lazy
+ (Inlining_cost.can_try_inlining function_body.body
+ inlining_threshold
+ ~number_of_arguments:(List.length function_decl.params)
+ (* CR-someday mshinwell: for the moment, this is None, since
+ the Inlining_cost code isn't checking sizes up to the max
+ inlining threshold---this seems to take too long. *)
+ ~size_from_approximation:None)
+ in
+ let recursive =
+ lazy
+ (let fun_var = Closure_id.unwrap closure_id_being_applied in
+ Variable.Set.mem fun_var
+ (Lazy.force value_set_of_closures.recursive))
+ in
+ let specialise_result =
+ specialise env r
+ ~function_decls ~function_decl
+ ~lhs_of_application ~recursive ~closure_id_being_applied
+ ~value_set_of_closures ~args ~args_approxs ~dbg ~simplify
+ ~original ~inline_requested ~specialise_requested ~fun_cost
+ ~self_call ~inlining_threshold
+ in
+ match specialise_result with
+ | Changed (res, spec_reason) ->
+ Changed (res, D.Specialised spec_reason)
+ | Original spec_reason ->
+ let only_use_of_function = false in
+ (* If we didn't specialise then try inlining *)
+ let size_from_approximation =
+ let fun_var = Closure_id.unwrap closure_id_being_applied in
+ match
+ Variable.Map.find fun_var (Lazy.force value_set_of_closures.size)
+ with
+ | size -> size
+ | exception Not_found ->
Misc.fatal_errorf "Approximation does not give a size for the \
- function having fun_var %a. value_set_of_closures: %a"
+ function having fun_var %a. value_set_of_closures: %a"
Variable.print fun_var
A.print_value_set_of_closures value_set_of_closures
+ in
+ let fun_vars = Variable.Map.keys function_decls.funs in
+ let set_of_closures_origin =
+ function_decls.set_of_closures_origin
+ in
+ let inline_result =
+ inline env r ~lhs_of_application
+ ~closure_id_being_applied ~function_decl ~value_set_of_closures
+ ~only_use_of_function ~original ~recursive
+ ~inline_requested ~specialise_requested
+ ~fun_vars ~set_of_closures_origin ~args
+ ~size_from_approximation ~dbg ~simplify ~fun_cost ~self_call
+ ~inlining_threshold ~function_body
+ in
+ match inline_result with
+ | Changed (res, inl_reason) ->
+ Changed (res, D.Inlined (spec_reason, inl_reason))
+ | Original inl_reason ->
+ Original (D.Unchanged (spec_reason, inl_reason))
+ end
+ in
+ let res, decision =
+ match simpl with
+ | Original decision -> (original, original_r), decision
+ | Changed ((expr, r), decision) ->
+ let res =
+ if E.inlining_level env = 0
+ then expr, R.set_inlining_threshold r raw_inlining_threshold
+ else expr, R.add_inlining_threshold r inlining_threshold_diff
in
- let inline_result =
- inline env r ~function_decls ~lhs_of_application
- ~closure_id_being_applied ~function_decl ~value_set_of_closures
- ~only_use_of_function ~original ~recursive
- ~inline_requested ~specialise_requested ~args
- ~size_from_approximation ~dbg ~simplify ~fun_cost ~self_call
- ~inlining_threshold
- in
- match inline_result with
- | Changed (res, inl_reason) ->
- Changed (res, D.Inlined (spec_reason, inl_reason))
- | Original inl_reason ->
- Original (D.Unchanged (spec_reason, inl_reason))
- end
- in
- let res, decision =
- match simpl with
- | Original decision -> (original, original_r), decision
- | Changed ((expr, r), decision) ->
- let res =
- if E.inlining_level env = 0
- then expr, R.set_inlining_threshold r raw_inlining_threshold
- else expr, R.add_inlining_threshold r inlining_threshold_diff
- in
- res, decision
- in
- E.record_decision env decision;
- res
- end
+ res, decision
+ in
+ E.record_decision env decision;
+ res
+ end
(* We do not inline inside stubs, which are always inlined at their call site.
Inlining inside the declaration of a stub could result in more code than
val for_call_site
: env:Inline_and_simplify_aux.Env.t
-> r:Inline_and_simplify_aux.Result.t
- -> function_decls:Flambda.function_declarations
+ -> function_decls:Simple_value_approx.function_declarations
-> lhs_of_application:Variable.t
-> closure_id_being_applied:Closure_id.t
- -> function_decl:Flambda.function_declaration
+ -> function_decl:Simple_value_approx.function_declaration
-> value_set_of_closures:Simple_value_approx.value_set_of_closures
-> args:Variable.t list
-> args_approxs:Simple_value_approx.t list
module Inlined = struct
type t =
+ | Classic_mode
| Annotation
| Decl_local_to_application
| Without_subfunctions of Wsb.t
| With_subfunctions of Wsb.t * Wsb.t
let summary ppf = function
+ | Classic_mode ->
+ Format.pp_print_text ppf
+ "This function was inlined because it was small enough \
+ to be inlined in `-Oclassic'"
| Annotation ->
Format.pp_print_text ppf
"This function was inlined because of an annotation."
the expected benefit outweighed the change in code size."
let calculation ~depth ppf = function
+ | Classic_mode -> ()
| Annotation -> ()
| Decl_local_to_application -> ()
| Without_subfunctions wsb ->
let summary ppf = function
| Classic_mode ->
Format.pp_print_text ppf
- "This function was prevented from inlining by `-Oclassic'."
+ "This function was not inlined because it was too \
+ large to be inlined in `-Oclassic'."
| Above_threshold size ->
Format.pp_print_text ppf
"This function was not inlined because \
let summary ppf = function
| Classic_mode ->
Format.pp_print_text ppf
- "This function was prevented from specialising by \
- `-Oclassic'."
+ "This function was not specialised because it was \
+ compiled with `-Oclassic'."
| Above_threshold size ->
Format.pp_print_text ppf
"This function was not specialised because \
module Inlined : sig
type t =
+ | Classic_mode
| Annotation
| Decl_local_to_application
| Without_subfunctions of
module B = Inlining_cost.Benefit
module E = Inline_and_simplify_aux.Env
module R = Inline_and_simplify_aux.Result
+module A = Simple_value_approx
let new_var name =
Variable.create name
~current_compilation_unit:(Compilation_unit.get_current_exn ())
-let which_function_parameters_can_we_specialise ~params ~args
- ~args_approxs ~(invariant_params:Variable.Set.t Variable.Map.t lazy_t)
- ~specialised_args =
- assert (List.length params = List.length args);
- assert (List.length args = List.length args_approxs);
- List.fold_right2 (fun (var, arg) approx
- (worth_specialising_args, spec_args, args, args_decl) ->
- let spec_args =
- if Variable.Map.mem var (Lazy.force invariant_params) ||
- Variable.Set.mem var specialised_args
- then
- Variable.Map.add var arg spec_args
- else
- spec_args
- in
- let worth_specialising_args =
- if Simple_value_approx.useful approx
- && Variable.Map.mem var (Lazy.force invariant_params)
- then
- Variable.Set.add var worth_specialising_args
- else
- worth_specialising_args
- in
- worth_specialising_args, spec_args, arg :: args, args_decl)
- (List.combine params args) args_approxs
- (Variable.Set.empty, Variable.Map.empty, [], [])
-
(** Fold over all variables bound by the given closure, which is bound to the
variable [lhs_of_application], and corresponds to the given
[function_decls]. Each variable bound by the closure is passed to the
user-specified function as an [Flambda.named] value that projects the
variable from its closure. *)
let fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied
- ~lhs_of_application ~function_decls ~init ~f =
+ ~lhs_of_application ~bound_variables ~init ~f =
Variable.Set.fold (fun var acc ->
let expr : Flambda.named =
Project_var {
}
in
f ~acc ~var ~expr)
- (Flambda_utils.variables_bound_by_the_closure closure_id_being_applied
- function_decls)
+ bound_variables
init
let set_inline_attribute_on_all_apply body inline specialise =
(** Assign fresh names for a function's parameters and rewrite the body to
use these new names. *)
let copy_of_function's_body_with_freshened_params env
- ~(function_decl : Flambda.function_declaration) =
+ ~(function_decl : A.function_declaration)
+ ~(function_body : A.function_body) =
let params = function_decl.params in
let param_vars = Parameter.List.vars params in
(* We cannot avoid the substitution in the case where we are inlining
if E.does_not_bind env param_vars
&& E.does_not_freshen env param_vars
then
- params, function_decl.body
+ params, function_body.body
else
let freshened_params = List.map (fun p -> Parameter.rename p) params in
let subst =
Variable.Map.of_list
(List.combine param_vars (Parameter.List.vars freshened_params))
in
- let body = Flambda_utils.toplevel_substitution subst function_decl.body in
+ let body = Flambda_utils.toplevel_substitution subst function_body.body in
freshened_params, body
(* CR-soon mshinwell: Add a note somewhere to explain why "bound by the closure"
(= "variables bound by the closure"), and any function identifiers
introduced by the corresponding set of closures. *)
let inline_by_copying_function_body ~env ~r
- ~(function_decls : Flambda.function_declarations)
~lhs_of_application
~(inline_requested : Lambda.inline_attribute)
~(specialise_requested : Lambda.specialise_attribute)
~closure_id_being_applied
- ~(function_decl : Flambda.function_declaration) ~args ~dbg ~simplify =
+ ~(function_decl : A.function_declaration)
+ ~(function_body : A.function_body)
+ ~fun_vars
+ ~args ~dbg ~simplify =
assert (E.mem env lhs_of_application);
assert (List.for_all (E.mem env) args);
let r =
- if function_decl.stub then r
+ if function_body.stub then r
else R.map_benefit r B.remove_call
in
let freshened_params, body =
- copy_of_function's_body_with_freshened_params env ~function_decl
+ copy_of_function's_body_with_freshened_params env
+ ~function_decl ~function_body
in
let body =
- if function_decl.stub &&
+ if function_body.stub &&
((inline_requested <> Lambda.Default_inline)
|| (specialise_requested <> Lambda.Default_specialise)) then
(* When the function inlined function is a stub, the annotation
in
(* Add bindings for the variables bound by the closure. *)
let bindings_for_vars_bound_by_closure_and_params_to_args =
+ let bound_variables =
+ let params = Parameter.Set.vars function_decl.params in
+ Variable.Set.diff
+ (Variable.Set.diff function_body.free_variables params)
+ fun_vars
+ in
fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied
- ~lhs_of_application ~function_decls ~init:bindings_for_params_to_args
+ ~lhs_of_application ~bound_variables ~init:bindings_for_params_to_args
~f:(fun ~acc:body ~var ~expr -> Flambda.create_let var expr body)
in
(* Add bindings for variables corresponding to the functions introduced by
applied to another closure in the same set.
*)
let expr =
- Variable.Map.fold (fun another_closure_in_the_same_set _ expr ->
+ Variable.Set.fold (fun another_closure_in_the_same_set expr ->
let used =
Variable.Set.mem another_closure_in_the_same_set
- function_decl.free_variables
+ function_body.free_variables
in
if used then
Flambda.create_let another_closure_in_the_same_set
})
expr
else expr)
- function_decls.funs
+ fun_vars
bindings_for_vars_bound_by_closure_and_params_to_args
in
- let env = E.activate_freshening (E.set_never_inline env) in
+ let env = E.set_never_inline env in
+ let env = E.activate_freshening env in
let env = E.set_inline_debuginfo ~dbg env in
simplify env r expr
-let inline_by_copying_function_declaration ~env ~r
- ~(function_decls : Flambda.function_declarations)
- ~lhs_of_application
- ~(inline_requested : Lambda.inline_attribute)
- ~closure_id_being_applied
- ~(function_decl : Flambda.function_declaration)
- ~args ~args_approxs
- ~(invariant_params:Variable.Set.t Variable.Map.t lazy_t)
- ~(specialised_args : Flambda.specialised_to Variable.Map.t)
- ~direct_call_surrogates ~dbg ~simplify =
- let function_decls =
- (* To simplify a substitution (see comment below), rewrite any references
- to closures in the set being defined that go via symbols, so they go
- via closure variables instead. *)
- let make_closure_symbol =
- let module Backend = (val (E.backend env) : Backend_intf.S) in
- Backend.closure_symbol
- in
- Freshening.rewrite_recursive_calls_with_symbols
- (Freshening.activate Freshening.empty)
- ~make_closure_symbol
- function_decls
+type state = {
+ old_inside_to_new_inside : Variable.t Variable.Map.t;
+ (* Map from old inner vars to new inner vars *)
+ old_outside_to_new_outside : Variable.t Variable.Map.t;
+ (* Map from old outer vars to new outer vars *)
+ old_params_to_new_outside : Variable.t Variable.Map.t;
+ (* Map from old parameters to new outer vars. These are params
+ that should be specialised if they are copied to the new set of
+ closures. *)
+ old_fun_var_to_new_fun_var : Variable.t Variable.Map.t;
+ (* Map from old fun vars to new fun vars. These are the functions
+ that will be copied into the new set of closures *)
+ let_bindings : (Variable.t * Flambda.named) list;
+ (* Let bindings that will surround the definition of the new set
+ of closures *)
+ to_copy : Variable.t list;
+ (* List of functions that still need to be copied to the new set
+ of closures *)
+ new_funs : Flambda.function_declaration Variable.Map.t;
+ (* The function declerations for the new set of closures *)
+ new_free_vars_with_old_projections : Flambda.specialised_to Variable.Map.t;
+ (* The free variables for the new set of closures, but the projection
+ fields still point to old free variables. *)
+ new_specialised_args_with_old_projections :
+ Flambda.specialised_to Variable.Map.t;
+ (* The specialised parameters for the new set of closures, but the
+ projection fields still point to old specialised parameters. *)
+}
+
+let empty_state =
+ { to_copy = [];
+ old_inside_to_new_inside = Variable.Map.empty;
+ old_outside_to_new_outside = Variable.Map.empty;
+ old_params_to_new_outside = Variable.Map.empty;
+ old_fun_var_to_new_fun_var = Variable.Map.empty;
+ let_bindings = [];
+ new_funs = Variable.Map.empty;
+ new_free_vars_with_old_projections = Variable.Map.empty;
+ new_specialised_args_with_old_projections = Variable.Map.empty; }
+
+(* Add let bindings for the free vars in the set_of_closures and
+ add them to [old_outside_to_new_outside] *)
+let bind_free_vars ~lhs_of_application ~closure_id_being_applied
+ ~state ~free_vars =
+ Variable.Map.fold
+ (fun free_var (spec : Flambda.specialised_to) state ->
+ let var_clos = new_var Internal_variable_names.from_closure in
+ let expr : Flambda.named =
+ Project_var {
+ closure = lhs_of_application;
+ closure_id = closure_id_being_applied;
+ var = Var_within_closure.wrap free_var;
+ }
+ in
+ let let_bindings = (var_clos, expr) :: state.let_bindings in
+ let old_outside_to_new_outside =
+ Variable.Map.add spec.var var_clos state.old_outside_to_new_outside
+ in
+ { state with let_bindings; old_outside_to_new_outside })
+ free_vars state
+
+(* For arguments of specialised parameters:
+ - Add them to [old_outside_to_new_outside]
+ - Add them and their invariant aliases to [old_params_to_new_outside]
+ For other arguments that are also worth specialising:
+ - Add them and their invariant aliases to [old_params_to_new_outside] *)
+let register_arguments ~specialised_args ~invariant_params
+ ~state ~params ~args ~args_approxs =
+ let rec loop ~state ~params ~args ~args_approxs =
+ match params, args, args_approxs with
+ | [], [], [] -> state
+ | param :: params, arg :: args, arg_approx :: args_approxs -> begin
+ let param = Parameter.var param in
+ let worth_specialising, old_outside_to_new_outside =
+ match Variable.Map.find_opt param specialised_args with
+ | Some (spec : Flambda.specialised_to) ->
+ let old_outside_to_new_outside =
+ Variable.Map.add spec.var arg state.old_outside_to_new_outside
+ in
+ true, old_outside_to_new_outside
+ | None ->
+ let worth_specialising =
+ A.useful arg_approx
+ && Variable.Map.mem param (Lazy.force invariant_params)
+ in
+ worth_specialising, state.old_outside_to_new_outside
+ in
+ let old_params_to_new_outside =
+ if worth_specialising then begin
+ let old_params_to_new_outside =
+ Variable.Map.add param arg state.old_params_to_new_outside
+ in
+ match Variable.Map.find_opt param (Lazy.force invariant_params) with
+ | Some set ->
+ Variable.Set.fold
+ (fun elem acc -> Variable.Map.add elem arg acc)
+ set old_params_to_new_outside
+ | None ->
+ old_params_to_new_outside
+ end else begin
+ state.old_params_to_new_outside
+ end
+ in
+ let state =
+ { state with old_outside_to_new_outside; old_params_to_new_outside }
+ in
+ loop ~state ~params ~args ~args_approxs
+ end
+ | _, _, _ -> assert false
in
- let original_function_decls = function_decls in
- let specialised_args_set = Variable.Map.keys specialised_args in
- let worth_specialising_args, specialisable_args, args, args_decl =
- which_function_parameters_can_we_specialise
- ~params:(Parameter.List.vars function_decl.params) ~args ~args_approxs
- ~invariant_params
- ~specialised_args:specialised_args_set
+ loop ~state ~params ~args ~args_approxs
+
+(* Add an old parameter to [old_inside_to_new_inside]. If it appears in
+ [old_params_to_new_outside] then also add it to the new specialised args. *)
+let add_param ~specialised_args ~state ~param =
+ let param = Parameter.var param in
+ let new_param = Variable.rename param in
+ let old_inside_to_new_inside =
+ Variable.Map.add param new_param state.old_inside_to_new_inside
in
- (* Arguments of functions that are not directly called but are
- aliased to arguments of a directly called one may need to be
- marked as specialised. *)
- let specialisable_args_with_aliases =
- Variable.Map.fold (fun arg outside_var map ->
- match Variable.Map.find arg (Lazy.force invariant_params) with
- | exception Not_found -> map
- | set ->
- Variable.Set.fold (fun alias map ->
- Variable.Map.add alias outside_var map)
- set map)
- specialisable_args specialisable_args
+ let new_specialised_args_with_old_projections =
+ match Variable.Map.find_opt param specialised_args with
+ | Some (spec : Flambda.specialised_to) ->
+ let new_outside_var =
+ Variable.Map.find spec.var state.old_outside_to_new_outside
+ in
+ let new_spec : Flambda.specialised_to =
+ { spec with var = new_outside_var }
+ in
+ Variable.Map.add new_param new_spec
+ state.new_specialised_args_with_old_projections
+ | None -> begin
+ match Variable.Map.find_opt param state.old_params_to_new_outside with
+ | None -> state.new_specialised_args_with_old_projections
+ | Some new_outside_var ->
+ let new_spec : Flambda.specialised_to =
+ { var = new_outside_var; projection = None }
+ in
+ Variable.Map.add new_param new_spec
+ state.new_specialised_args_with_old_projections
+ end
in
- (* The other closures from the same set of closures may have
- specialised arguments. Those refer to variables that may not be
- bound anymore in the current environment. The only allowed
- remaining specialised arguments after duplicating a function are
- those that either comes from the free variables of set of
- closures or the arguments of the closure being applied (and
- propagated transitively to other functions). This is ensured by
- the fact that no closure not directly required by the closure
- being applied are kept in the set. If an argument of an other
- function of the set does not come from the closure being applied
- then, that function cannot be applied (unreachable from the one
- being aplied).
-
- For specialised arguments of other function to reference a valid
- value, they need to be rewritten accordingly to the ones of the
- closure being applied. *)
- let specialisable_renaming =
- Variable.Map.fold (fun param outside_var map ->
- match Variable.Map.find param specialised_args with
- | exception Not_found ->
- (* Newly specialised argument: no other function argument
- may need renaming for that one *)
- map
- | original_spec_to ->
- let original_outside_var = original_spec_to.var in
- let spec_to =
- { original_spec_to with var = outside_var; }
- in
- Variable.Map.add original_outside_var spec_to map)
- specialisable_args_with_aliases Variable.Map.empty
+ let state =
+ { state with old_inside_to_new_inside;
+ new_specialised_args_with_old_projections }
in
- if Variable.Set.subset worth_specialising_args specialised_args_set
- then
- (* Don't duplicate the function definition if we would make its
- specialisation information worse. (Note that this judgement is made
- based only on those arguments found to be invariant with known-useful
- approximations, rather than on all invariant arguments.) *)
- None
- else
- let set_of_closures_var = new_var "dup_set_of_closures" in
- (* The free variable map for the duplicated declaration(s) maps the
- "internal" names used within the function bodies to fresh names,
- which in turn are bound to projections from the set of closures being
- copied. We add these bindings using [Let] around the new
- set-of-closures declaration. *)
- let free_vars, free_vars_for_lets =
- fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied
- ~lhs_of_application ~function_decls ~init:(Variable.Map.empty, [])
- ~f:(fun ~acc:(map, for_lets) ~var:internal_var ~expr ->
- let from_closure : Flambda.specialised_to =
- { var = new_var "from_closure";
- projection = None;
- }
- in
- Variable.Map.add internal_var from_closure map,
- (from_closure.var, expr)::for_lets)
+ state, Parameter.wrap new_param
+
+(* Add a let binding for an old fun_var, add it to the new free variables, and
+ add it to [old_inside_to_new_inside] *)
+let add_fun_var ~lhs_of_application ~closure_id_being_applied ~state ~fun_var =
+ if Variable.Map.mem fun_var state.old_inside_to_new_inside then state
+ else begin
+ let inside_var = Variable.rename fun_var in
+ let outside_var = Variable.create Internal_variable_names.closure in
+ let expr =
+ Flambda.Move_within_set_of_closures
+ { closure = lhs_of_application;
+ start_from = closure_id_being_applied;
+ move_to = Closure_id.wrap fun_var; }
in
- let required_functions =
- Flambda_utils.closures_required_by_entry_point ~backend:(E.backend env)
- ~entry_point:closure_id_being_applied
- function_decls
+ let let_bindings = (outside_var, expr) :: state.let_bindings in
+ let spec : Flambda.specialised_to =
+ { var = outside_var; projection = None; }
in
- let funs =
- Variable.Map.filter (fun func _ ->
- Variable.Set.mem func required_functions)
- function_decls.funs
+ let new_free_vars_with_old_projections =
+ Variable.Map.add inside_var spec state.new_free_vars_with_old_projections
in
- let free_vars, free_vars_for_lets, original_vars =
- (* Bind all the closures from the original (non-specialised) set as
- free variables in the set. This means that we can reference them
- when some particular recursive call cannot be specialised. See
- detailed comment below. *)
- Variable.Map.fold (fun fun_var _fun_decl
- (free_vars, free_vars_for_lets, original_vars) ->
- let var = Variable.create "closure" in
- let original_closure : Flambda.named =
- Move_within_set_of_closures
- { closure = lhs_of_application;
- start_from = closure_id_being_applied;
- move_to = Closure_id.wrap fun_var;
- }
- in
- let internal_var = Variable.rename ~append:"_original" fun_var in
- let free_vars =
- Variable.Map.add internal_var { Flambda. var; projection = None }
- free_vars
- in
- free_vars,
- (var, original_closure) :: free_vars_for_lets,
- Variable.Map.add fun_var internal_var original_vars)
- funs
- (free_vars, free_vars_for_lets, Variable.Map.empty)
+ let old_inside_to_new_inside =
+ Variable.Map.add fun_var inside_var state.old_inside_to_new_inside
in
- let direct_call_surrogates =
- Closure_id.Map.fold (fun existing surrogate surrogates ->
- let existing = Closure_id.unwrap existing in
- let surrogate = Closure_id.unwrap surrogate in
- if Variable.Map.mem existing funs
- && Variable.Map.mem surrogate funs
- then
- Variable.Map.add existing surrogate surrogates
- else
- surrogates)
- direct_call_surrogates
- Variable.Map.empty
+ { state with
+ old_inside_to_new_inside; let_bindings;
+ new_free_vars_with_old_projections }
+ end
+
+(* Add an old free_var to the new free variables and add it to
+ [old_inside_to_new_inside]. *)
+let add_free_var ~free_vars ~state ~free_var =
+ if Variable.Map.mem free_var state.old_inside_to_new_inside then state
+ else begin
+ let spec : Flambda.specialised_to = Variable.Map.find free_var free_vars in
+ let outside_var = spec.var in
+ let new_outside_var =
+ Variable.Map.find outside_var state.old_outside_to_new_outside
in
- let function_decls =
- Flambda.update_function_declarations ~funs function_decls
+ let new_spec : Flambda.specialised_to =
+ { spec with var = new_outside_var }
in
- let all_functions_parameters =
- Flambda_utils.all_functions_parameters function_decls
+ let new_inside_var = Variable.rename free_var in
+ let new_free_vars_with_old_projections =
+ Variable.Map.add new_inside_var new_spec
+ state.new_free_vars_with_old_projections
in
- let specialisable_args =
- Variable.Map.merge (fun param v1 v2 ->
- match v1, v2 with
- | None, None -> None
- | Some var, _ ->
- (* New specialised argument being introduced. *)
- let spec_to : Flambda.specialised_to =
- { var;
- projection = None;
- }
- in
- Some spec_to
- | None, Some (spec_to : Flambda.specialised_to) ->
- (* Renaming an existing specialised argument. *)
- if Variable.Set.mem param all_functions_parameters then
- match Variable.Map.find spec_to.var specialisable_renaming with
- | exception Not_found ->
- Misc.fatal_errorf
- "Missing renaming for specialised argument of a function \
- being duplicated but not directly applied: %a -> %a.@ \
- Closure ID being applied = %a.@ \
- required_functions = %a.@ \
- specialisable_renaming = %a@ \
- specialisable_args_with_aliases = %a@ \
- Original function declarations = %a@ \
- Filtered function declarations = %a@ \
- Original specialised args = %a"
- Variable.print param
- Flambda.print_specialised_to spec_to
- Closure_id.print closure_id_being_applied
- Variable.Set.print required_functions
- (Variable.Map.print Flambda.print_specialised_to)
- specialisable_renaming
- (Variable.Map.print Variable.print)
- specialisable_args_with_aliases
- Flambda.print_function_declarations original_function_decls
- Flambda.print_function_declarations function_decls
- (Variable.Map.print Flambda.print_specialised_to)
- specialised_args
- | argument_from_the_current_application ->
- Some argument_from_the_current_application
- else
- None)
- specialisable_args_with_aliases specialised_args
+ let old_inside_to_new_inside =
+ Variable.Map.add free_var new_inside_var state.old_inside_to_new_inside
in
- let functions'_specialised_params =
- Flambda_utils.parameters_specialised_to_the_same_variable
- ~function_decls
- ~specialised_args:specialisable_args
+ { state with old_inside_to_new_inside; new_free_vars_with_old_projections }
+ end
+
+(* Add a function to the new set of closures iff:
+ 1) All it's specialised parameters are available in
+ [old_outside_to_new_outside]
+ 2) At least one more parameter will become specialised *)
+let add_function ~specialised_args ~state ~fun_var ~function_decl =
+ match function_decl.A.function_body with
+ | None -> None
+ | Some _ -> begin
+ let rec loop worth_specialising = function
+ | [] -> worth_specialising
+ | param :: params -> begin
+ let param = Parameter.var param in
+ match Variable.Map.find_opt param specialised_args with
+ | Some (spec : Flambda.specialised_to) ->
+ Variable.Map.mem spec.var state.old_outside_to_new_outside
+ && loop worth_specialising params
+ | None ->
+ let worth_specialising =
+ worth_specialising
+ || Variable.Map.mem param state.old_params_to_new_outside
+ in
+ loop worth_specialising params
+ end
in
- let rewrite_function (fun_decl:Flambda.function_declaration) =
- (* First rewrite every use of the closure(s) defined by the current set
- of closures to free variable(s) corresponding to the original
- (non-specialised) closure(s).
+ let worth_specialising = loop false function_decl.A.params in
+ if not worth_specialising then None
+ else begin
+ let new_fun_var = Variable.rename fun_var in
+ let old_fun_var_to_new_fun_var =
+ Variable.Map.add fun_var new_fun_var state.old_fun_var_to_new_fun_var
+ in
+ let to_copy = fun_var :: state.to_copy in
+ let state = { state with old_fun_var_to_new_fun_var; to_copy } in
+ Some (state, new_fun_var)
+ end
+ end
+
+(* Lookup a function in the new set of closures, trying to add it if
+ necessary. *)
+let lookup_function ~specialised_args ~state ~fun_var ~function_decl =
+ match Variable.Map.find_opt fun_var state.old_fun_var_to_new_fun_var with
+ | Some new_fun_var -> Some (state, new_fun_var)
+ | None -> add_function ~specialised_args ~state ~fun_var ~function_decl
- Then for each call to such closures, if the arguments to the call are
- obviously the same as the arguments to which we are specialising the
- function, redirect the call to the specialised function.
+(* A direct call to a function in the new set of closures can be specialised
+ if all the function's newly specialised parameters are passed arguments
+ that are specialised to the same outside variable *)
+let specialisable_call ~specialised_args ~state ~args ~params =
+ List.for_all2
+ (fun arg param ->
+ let param = Parameter.var param in
+ if Variable.Map.mem param specialised_args then true
+ else begin
+ let old_params_to_new_outside = state.old_params_to_new_outside in
+ match Variable.Map.find_opt param old_params_to_new_outside with
+ | None -> true
+ | Some outside_var -> begin
+ match Variable.Map.find_opt arg old_params_to_new_outside with
+ | Some outside_var' ->
+ Variable.equal outside_var outside_var'
+ | None -> false
+ end
+ end)
+ args params
+
+(* Rewrite a call iff:
+ 1) It is to a function in the old set of closures that can be specialised
+ 2) All the newly specialised parameters of that function are passed values
+ known to be equal to their new specialisation. *)
+let rec rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates
+ ~state ~closure_id ~(apply : Flambda.apply) =
+ match Closure_id.Map.find_opt closure_id direct_call_surrogates with
+ | Some closure_id ->
+ rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates
+ ~state ~closure_id ~apply
+ | None -> begin
+ let fun_var = Closure_id.unwrap closure_id in
+ match Variable.Map.find_opt fun_var funs with
+ | None -> None
+ | Some function_decl -> begin
+ match
+ lookup_function ~specialised_args ~state ~fun_var ~function_decl
+ with
+ | None -> None
+ | Some (state, new_fun_var) -> begin
+ let args = apply.args in
+ let params = function_decl.A.params in
+ let specialisable =
+ specialisable_call ~specialised_args ~state ~args ~params
+ in
+ if not specialisable then None
+ else begin
+ let kind = Flambda.Direct (Closure_id.wrap new_fun_var) in
+ let apply = { apply with func = new_fun_var; kind } in
+ Some (state, Flambda.Apply apply)
+ end
+ end
+ end
+ end
- In a function like [List.map]:
- {[
- let rec specialised_map f l =
- match l with
- | [] -> []
- | h :: t -> f h :: specialised_map f t
- ]} ( with [f] a specialised argument )
+(* Rewrite the body a function declaration for use in the new set of
+ closures. *)
+let rewrite_function ~lhs_of_application ~closure_id_being_applied
+ ~direct_call_surrogates ~specialised_args ~free_vars ~funs
+ ~state fun_var =
+ let function_decl : A.function_declaration =
+ Variable.Map.find fun_var funs
+ in
+ let function_body =
+ match function_decl.function_body with
+ | None -> assert false
+ | Some function_body -> function_body
+ in
+ let new_fun_var =
+ Variable.Map.find fun_var state.old_fun_var_to_new_fun_var
+ in
+ let state, params =
+ List.fold_right
+ (fun param (state, params) ->
+ let state, param = add_param ~specialised_args ~state ~param in
+ (state, param :: params))
+ function_decl.params (state, [])
+ in
+ let state =
+ Variable.Set.fold
+ (fun var state ->
+ if Variable.Map.mem var funs then
+ add_fun_var ~lhs_of_application ~closure_id_being_applied
+ ~state ~fun_var:var
+ else if Variable.Map.mem var free_vars then
+ add_free_var ~free_vars ~state ~free_var:var
+ else
+ state)
+ function_body.free_variables state
+ in
+ let state_ref = ref state in
+ let body =
+ Flambda_iterators.map_toplevel_expr
+ (fun (expr : Flambda.t) ->
+ match expr with
+ | Apply ({ kind = Direct closure_id } as apply) -> begin
+ match
+ rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates
+ ~state:!state_ref ~closure_id ~apply
+ with
+ | None -> expr
+ | Some (state, expr) ->
+ state_ref := state;
+ expr
+ end
+ | _ -> expr)
+ function_body.body
+ in
+ let body =
+ Flambda_utils.toplevel_substitution state.old_inside_to_new_inside body
+ in
+ let new_function_decl =
+ Flambda.create_function_declaration
+ ~params ~body
+ ~stub:function_body.stub
+ ~dbg:function_body.dbg
+ ~inline:function_body.inline
+ ~specialise:function_body.specialise
+ ~is_a_functor:function_body.is_a_functor
+ ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var))
+ in
+ let new_funs =
+ Variable.Map.add new_fun_var new_function_decl state.new_funs
+ in
+ let state = { !state_ref with new_funs } in
+ state
- The first step turns it into:
- {[
- let map_original = map in
- let rec specialised_map f l =
- match l with
- | [] -> []
- | h :: t -> f h :: map_original f t
- ]}
- and the second recognizes the call to [map_original] as a call
- preserving the specialised arguments (here [f]). So it is
- replaced by [specialised_map f t].
+let update_projections ~state projections =
+ let old_to_new = state.old_inside_to_new_inside in
+ Variable.Map.map
+ (fun (spec_to : Flambda.specialised_to) ->
+ let projection : Projection.t option =
+ match spec_to.projection with
+ | None -> None
+ | Some (Project_var proj) -> begin
+ match Variable.Map.find_opt proj.closure old_to_new with
+ | None -> None
+ | Some closure ->
+ let proj = { proj with closure } in
+ Some (Projection.Project_var proj)
+ end
+ | Some (Project_closure proj) -> begin
+ match Variable.Map.find_opt proj.set_of_closures old_to_new with
+ | None -> None
+ | Some set_of_closures ->
+ let proj = { proj with set_of_closures } in
+ Some (Projection.Project_closure proj)
+ end
+ | Some (Move_within_set_of_closures proj) -> begin
+ match Variable.Map.find_opt proj.closure old_to_new with
+ | None -> None
+ | Some closure ->
+ let proj = { proj with closure } in
+ Some (Projection.Move_within_set_of_closures proj)
+ end
+ | Some (Field (index, var)) -> begin
+ match Variable.Map.find_opt var old_to_new with
+ | None -> None
+ | Some var -> Some (Projection.Field(index, var))
+ end
+ in
+ { spec_to with projection })
+ projections
- In the case of [map] this is a circuituous means of achieving the
- desired result, but in general, this provides a way of handling
- situations where some recursive calls (for example in subfunctions)
- are made with arguments different from the specialised arguments.
- The two-pass approach is convenient since the first pass performs
- a correct code transformation without optimisation; and then the
- second just performs the optimisation on a best-effort basis.
- *)
- let body_substituted =
- (* The use of [Freshening.rewrite_recursive_calls_with_symbols] above
- ensures that we catch all calls to the functions being defined
- in the current set of closures. *)
- Flambda_utils.toplevel_substitution original_vars fun_decl.body
+let inline_by_copying_function_declaration
+ ~(env : Inline_and_simplify_aux.Env.t)
+ ~(r : Inline_and_simplify_aux.Result.t)
+ ~(function_decls : A.function_declarations)
+ ~(lhs_of_application : Variable.t)
+ ~(inline_requested : Lambda.inline_attribute)
+ ~(closure_id_being_applied : Closure_id.t)
+ ~(function_decl : A.function_declaration)
+ ~(args : Variable.t list)
+ ~(args_approxs : A.t list)
+ ~(invariant_params : Variable.Set.t Variable.Map.t lazy_t)
+ ~(specialised_args : Flambda.specialised_to Variable.Map.t)
+ ~(free_vars : Flambda.specialised_to Variable.Map.t)
+ ~(direct_call_surrogates : Closure_id.t Closure_id.Map.t)
+ ~(dbg : Debuginfo.t)
+ ~(simplify : Inlining_decision_intf.simplify) =
+ let state = empty_state in
+ let state =
+ bind_free_vars ~lhs_of_application ~closure_id_being_applied
+ ~state ~free_vars
+ in
+ let params = function_decl.params in
+ let state =
+ register_arguments ~specialised_args ~invariant_params
+ ~state ~params ~args ~args_approxs
+ in
+ let fun_var = Closure_id.unwrap closure_id_being_applied in
+ match add_function ~specialised_args ~state ~fun_var ~function_decl with
+ | None -> None
+ | Some (state, new_fun_var) -> begin
+ let funs = function_decls.funs in
+ let rec loop state =
+ match state.to_copy with
+ | [] -> state
+ | next :: rest ->
+ let state = { state with to_copy = rest } in
+ let state =
+ rewrite_function ~lhs_of_application ~closure_id_being_applied
+ ~direct_call_surrogates ~specialised_args ~free_vars ~funs
+ ~state next
+ in
+ loop state
in
- let body =
- Flambda_iterators.map_toplevel_expr (fun (expr : Flambda.t) ->
- match expr with
- | Apply apply ->
- begin match apply.kind with
- | Indirect -> expr
- | Direct closure_id ->
- (* We recognize the potential recursive calls using the
- closure ID rather than [apply.func] because the latter can be
- aliases to the function (through a symbol for instance; the
- fact that we've now rewritten such symbols to variables
- doesn't squash any aliases) rather than being the closure var
- directly. *)
- let closure_var = Closure_id.unwrap closure_id in
- begin match
- Variable.Map.find closure_var functions'_specialised_params
- with
- | exception Not_found -> expr
- | specialised_params ->
- (* This is a call to one of the functions from the set being
- specialised. *)
- let apply_is_preserving_specialised_args =
- List.length apply.args = List.length specialised_params
- && List.for_all2 (fun arg param ->
- match
- (arg : Flambda_utils.specialised_to_same_as)
- with
- | Not_specialised -> true
- | Specialised_and_aliased_to args ->
- (* This is using one of the aliases of [param]. This
- is not necessarily the exact same variable as
- the original parameter---in particular when the
- set contains multiply-recursive functions. *)
- Variable.Set.mem param args)
- specialised_params
- apply.args
- in
- if apply_is_preserving_specialised_args then
- Flambda.Apply
- { apply with
- func = closure_var;
- kind = Direct closure_id;
- }
- else
- expr
- end
- end
- | _ -> expr)
- body_substituted
+ let state = loop state in
+ let closure_id = Closure_id.wrap new_fun_var in
+ let function_decls =
+ Flambda.create_function_declarations_with_origin
+ ~funs:state.new_funs
+ ~set_of_closures_origin:function_decls.set_of_closures_origin
+ ~is_classic_mode:function_decls.is_classic_mode
in
- Flambda.create_function_declaration
- ~params:fun_decl.params
- ~stub:fun_decl.stub
- ~dbg:fun_decl.dbg
- ~inline:fun_decl.inline
- ~specialise:fun_decl.specialise
- ~is_a_functor:fun_decl.is_a_functor
- ~body
- in
- let funs =
- Variable.Map.map rewrite_function function_decls.funs
- in
- let function_decls =
- Flambda.update_function_declarations ~funs function_decls
- in
- let set_of_closures =
- (* This is the new set of closures, with more precise specialisation
- information than the one being copied. *)
- Flambda.create_set_of_closures ~function_decls ~free_vars
- ~specialised_args:specialisable_args
- ~direct_call_surrogates
- in
- (* Generate a copy of the function application, including the function
- declaration(s), but with variables (not yet bound) in place of the
- arguments. *)
- let duplicated_application : Flambda.t =
- let project_closure : Flambda.project_closure =
- { set_of_closures = set_of_closures_var;
- closure_id = closure_id_being_applied;
- }
+ let free_vars =
+ update_projections ~state
+ state.new_free_vars_with_old_projections
in
- let func = new_var "dup_func" in
- let body : Flambda.t =
- Flambda.create_let set_of_closures_var
- (Set_of_closures set_of_closures)
- (Flambda.create_let func (Project_closure project_closure)
- (Apply {
- func;
- args;
- kind = Direct closure_id_being_applied;
- dbg;
- inline = inline_requested;
- specialise = Default_specialise;
- }))
+ let specialised_args =
+ update_projections ~state
+ state.new_specialised_args_with_old_projections
in
- Flambda_utils.bind ~bindings:free_vars_for_lets ~body
- in
- (* Now bind the variables that will hold the arguments from the original
- application. *)
- let expr : Flambda.t =
- Flambda_utils.bind ~body:duplicated_application ~bindings:args_decl
- in
- let env = E.activate_freshening (E.set_never_inline env) in
- Some (simplify env r expr)
+ let direct_call_surrogates = Variable.Map.empty in
+ let set_of_closures =
+ Flambda.create_set_of_closures ~function_decls
+ ~free_vars ~specialised_args ~direct_call_surrogates
+ in
+ let closure_var = new_var Internal_variable_names.dup_func in
+ let set_of_closures_var =
+ new_var Internal_variable_names.dup_set_of_closures
+ in
+ let project : Flambda.project_closure =
+ {set_of_closures = set_of_closures_var; closure_id}
+ in
+ let apply : Flambda.apply =
+ { func = closure_var; args; kind = Direct closure_id; dbg;
+ inline = inline_requested; specialise = Default_specialise; }
+ in
+ let body =
+ Flambda.create_let
+ set_of_closures_var (Set_of_closures set_of_closures)
+ (Flambda.create_let closure_var (Project_closure project)
+ (Apply apply))
+ in
+ let expr = Flambda_utils.bind ~body ~bindings:state.let_bindings in
+ let env = E.activate_freshening (E.set_never_inline env) in
+ Some (simplify env r expr)
+ end
val inline_by_copying_function_body
: env:Inline_and_simplify_aux.Env.t
-> r:Inline_and_simplify_aux.Result.t
- -> function_decls:Flambda.function_declarations
-> lhs_of_application:Variable.t
-> inline_requested:Lambda.inline_attribute
-> specialise_requested:Lambda.specialise_attribute
-> closure_id_being_applied:Closure_id.t
- -> function_decl:Flambda.function_declaration
+ -> function_decl:Simple_value_approx.function_declaration
+ -> function_body:Simple_value_approx.function_body
+ -> fun_vars:Variable.Set.t
-> args:Variable.t list
-> dbg:Debuginfo.t
-> simplify:Inlining_decision_intf.simplify
val inline_by_copying_function_declaration
: env:Inline_and_simplify_aux.Env.t
-> r:Inline_and_simplify_aux.Result.t
- -> function_decls:Flambda.function_declarations
+ -> function_decls:Simple_value_approx.function_declarations
-> lhs_of_application:Variable.t
-> inline_requested:Lambda.inline_attribute
-> closure_id_being_applied:Closure_id.t
- -> function_decl:Flambda.function_declaration
+ -> function_decl:Simple_value_approx.function_declaration
-> args:Variable.t list
-> args_approxs:Simple_value_approx.t list
-> invariant_params:Variable.Set.t Variable.Map.t lazy_t
-> specialised_args:Flambda.specialised_to Variable.Map.t
+ -> free_vars:Flambda.specialised_to Variable.Map.t
-> direct_call_surrogates:Closure_id.t Closure_id.Map.t
-> dbg:Debuginfo.t
-> simplify:Inlining_decision_intf.simplify
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Fu Yong Quah, Jane Street Europe *)
+(* *)
+(* Copyright 2017 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+type t = string
+
+let anon_fn = "anon_fn"
+let apply_arg = "apply_arg"
+let apply_funct = "apply_funct"
+let block_symbol = "block_symbol"
+let block_symbol_get = "block_symbol_get"
+let block_symbol_get_field = "block_symbol_get_field"
+let closure = "closure"
+let cond = "cond"
+let cond_sequor = "cond_sequor"
+let const_block = "const_block"
+let const_bool = "const_bool"
+let const_boxed_int = "const_boxed_int"
+let const_char = "const_char"
+let const_false = "const_false"
+let const_float = "const_float"
+let const_int = "const_int"
+let const_one = "const_one"
+let const_ptr = "const_ptr"
+let const_ptr_one = "const_ptr_one"
+let const_ptr_zero = "const_ptr_zero"
+let const_sequand = "const_sequand"
+let const_string = "const_string"
+let const_true = "const_true"
+let const_zero = "const_zero"
+let denominator = "denominator"
+let division_by_zero = "division_by_zero"
+let dummy = "dummy"
+let dup_func = "dup_func"
+let dup_set_of_closures = "dup_set_of_closures"
+let const_float_array = "const_float_array"
+let fake_effect_symbol = "fake_effect_symbol"
+let for_from = "for_from"
+let for_to = "for_to"
+let from_closure = "from_closure"
+let full_apply = "full_apply"
+let get_symbol_field = "get_symbol_field"
+let const_immstring = "const_immstring"
+let const_int32 = "const_int32"
+let const_int64 = "const_int64"
+let is_zero = "is_zero"
+let lifted_let_rec_block = "lifted_let_rec_block"
+let meth = "meth"
+let module_as_block = "module_as_block"
+let const_nativeint = "const_nativeint"
+let new_value = "new_value"
+let numerator = "numerator"
+let obj = "obj"
+let offsetted = "offsetted"
+let pabsfloat = "Pabsfloat"
+let paddbint = "Paddbint"
+let paddfloat = "Paddfloat"
+let paddint = "Paddint"
+let pandbint = "Pandbint"
+let pandint = "Pandint"
+let parraylength = "Parraylength"
+let parrayrefs = "Parrayrefs"
+let parrayrefu = "Parrayrefu"
+let parraysets = "Parraysets"
+let parraysetu = "Parraysetu"
+let pasrbint = "Pasrbint"
+let pasrint = "Pasrint"
+let pbbswap = "Pbbswap"
+let pbigarraydim = "Pbigarraydim"
+let pbigarrayref = "Pbigarrayref"
+let pbigarrayset = "Pbigarrayset"
+let pbigstring_load_16 = "Pbigstring_load_16"
+let pbigstring_load_32 = "Pbigstring_load_32"
+let pbigstring_load_64 = "Pbigstring_load_64"
+let pbigstring_set_16 = "Pbigstring_set_16"
+let pbigstring_set_32 = "Pbigstring_set_32"
+let pbigstring_set_64 = "Pbigstring_set_64"
+let pbintcomp = "Pbintcomp"
+let pbintofint = "Pbintofint"
+let pbswap16 = "Pbswap16"
+let pbytes_of_string = "Pbytes_of_string"
+let pbytes_load_16 = "Pbytes_load_16"
+let pbytes_load_32 = "Pbytes_load_32"
+let pbytes_load_64 = "Pbytes_load_64"
+let pbytes_set_16 = "Pbytes_set_16"
+let pbytes_set_32 = "Pbytes_set_32"
+let pbytes_set_64 = "Pbytes_set_64"
+let pbytes_to_string = "Pbytes_to_string"
+let pbyteslength = "Pbyteslength"
+let pbytesrefs = "Pbytesrefs"
+let pbytesrefu = "Pbytesrefu"
+let pbytessets = "Pbytessets"
+let pbytessetu = "Pbytessetu"
+let pccall = "Pccall"
+let pctconst = "Pctconst"
+let pcvtbint = "Pcvtbint"
+let pdirapply = "Pdirapply"
+let pdivbint = "Pdivbint"
+let pdivfloat = "Pdivfloat"
+let pdivint = "Pdivint"
+let pduparray = "Pduparray"
+let pduprecord = "Pduprecord"
+let pfield = "Pfield"
+let pfield_computed = "Pfield_computed"
+let pfloatcomp = "Pfloatcomp"
+let pfloatfield = "Pfloatfield"
+let pfloatofint = "Pfloatofint"
+let pgetglobal = "Pgetglobal"
+let pidentity = "Pidentity"
+let pignore = "Pignore"
+let pint_as_pointer = "Pint_as_pointer"
+let pintcomp = "Pintcomp"
+let pintofbint = "Pintofbint"
+let pintoffloat = "Pintoffloat"
+let pisint = "Pisint"
+let pisout = "Pisout"
+let plslbint = "Plslbint"
+let plslint = "Plslint"
+let plsrbint = "Plsrbint"
+let plsrint = "Plsrint"
+let pmakearray = "Pmakearray"
+let pmakeblock = "Pmakeblock"
+let pmodbint = "Pmodbint"
+let pmodint = "Pmodint"
+let pmulbint = "Pmulbint"
+let pmulfloat = "Pmulfloat"
+let pmulint = "Pmulint"
+let pnegbint = "Pnegbint"
+let pnegfloat = "Pnegfloat"
+let pnegint = "Pnegint"
+let pnot = "Pnot"
+let poffsetint = "Poffsetint"
+let poffsetref = "Poffsetref"
+let pointer = "pointer"
+let popaque = "Popaque"
+let porbint = "Porbint"
+let porint = "Porint"
+let praise = "Praise"
+let predef_exn = "predef_exn"
+let prevapply = "Prevapply"
+let project_closure = "project_closure"
+let psequand = "Psequand"
+let psequor = "Psequor"
+let psetfield = "Psetfield"
+let psetfield_computed = "Psetfield_computed"
+let psetfloatfield = "Psetfloatfield"
+let psetglobal = "Psetglobal"
+let pstring_load_16 = "Pstring_load_16"
+let pstring_load_32 = "Pstring_load_32"
+let pstring_load_64 = "Pstring_load_64"
+let pstringlength = "Pstringlength"
+let pstringrefs = "Pstringrefs"
+let pstringrefu = "Pstringrefu"
+let psubbint = "Psubbint"
+let psubfloat = "Psubfloat"
+let psubint = "Psubint"
+let pxorbint = "Pxorbint"
+let pxorint = "Pxorint"
+let pabsfloat_arg = "Pabsfloat_arg"
+let paddbint_arg = "Paddbint_arg"
+let paddfloat_arg = "Paddfloat_arg"
+let paddint_arg = "Paddint_arg"
+let pandbint_arg = "Pandbint_arg"
+let pandint_arg = "Pandint_arg"
+let parraylength_arg = "Parraylength_arg"
+let parrayrefs_arg = "Parrayrefs_arg"
+let parrayrefu_arg = "Parrayrefu_arg"
+let parraysets_arg = "Parraysets_arg"
+let parraysetu_arg = "Parraysetu_arg"
+let partial_fun = "partial_fun"
+let pasrbint_arg = "Pasrbint_arg"
+let pasrint_arg = "Pasrint_arg"
+let pbbswap_arg = "Pbbswap_arg"
+let pbigarraydim_arg = "Pbigarraydim_arg"
+let pbigarrayref_arg = "Pbigarrayref_arg"
+let pbigarrayset_arg = "Pbigarrayset_arg"
+let pbigstring_load_16_arg = "Pbigstring_load_16_arg"
+let pbigstring_load_32_arg = "Pbigstring_load_32_arg"
+let pbigstring_load_64_arg = "Pbigstring_load_64_arg"
+let pbigstring_set_16_arg = "Pbigstring_set_16_arg"
+let pbigstring_set_32_arg = "Pbigstring_set_32_arg"
+let pbigstring_set_64_arg = "Pbigstring_set_64_arg"
+let pbintcomp_arg = "Pbintcomp_arg"
+let pbintofint_arg = "Pbintofint_arg"
+let pbswap16_arg = "Pbswap16_arg"
+let pbytes_of_string_arg = "Pbytes_of_string_arg"
+let pbytes_to_string_arg = "Pbytes_to_string_arg"
+let pbyteslength_arg = "Pbyteslength_arg"
+let pbytesrefs_arg = "Pbytesrefs_arg"
+let pbytesrefu_arg = "Pbytesrefu_arg"
+let pbytessets_arg = "Pbytessets_arg"
+let pbytessetu_arg = "Pbytessetu_arg"
+let pccall_arg = "Pccall_arg"
+let pctconst_arg = "Pctconst_arg"
+let pcvtbint_arg = "Pcvtbint_arg"
+let pdirapply_arg = "Pdirapply_arg"
+let pdivbint_arg = "Pdivbint_arg"
+let pdivfloat_arg = "Pdivfloat_arg"
+let pdivint_arg = "Pdivint_arg"
+let pduparray_arg = "Pduparray_arg"
+let pduprecord_arg = "Pduprecord_arg"
+let pfield_arg = "Pfield_arg"
+let pfield_computed_arg = "Pfield_computed_arg"
+let pfloatcomp_arg = "Pfloatcomp_arg"
+let pfloatfield_arg = "Pfloatfield_arg"
+let pfloatofint_arg = "Pfloatofint_arg"
+let pgetglobal_arg = "Pgetglobal_arg"
+let pidentity_arg = "Pidentity_arg"
+let pignore_arg = "Pignore_arg"
+let pint_as_pointer_arg = "Pint_as_pointer_arg"
+let pintcomp_arg = "Pintcomp_arg"
+let pintofbint_arg = "Pintofbint_arg"
+let pintoffloat_arg = "Pintoffloat_arg"
+let pisint_arg = "Pisint_arg"
+let pisout_arg = "Pisout_arg"
+let plslbint_arg = "Plslbint_arg"
+let plslint_arg = "Plslint_arg"
+let plsrbint_arg = "Plsrbint_arg"
+let plsrint_arg = "Plsrint_arg"
+let pmakearray_arg = "Pmakearray_arg"
+let pmakeblock_arg = "Pmakeblock_arg"
+let pmodbint_arg = "Pmodbint_arg"
+let pmodint_arg = "Pmodint_arg"
+let pmulbint_arg = "Pmulbint_arg"
+let pmulfloat_arg = "Pmulfloat_arg"
+let pmulint_arg = "Pmulint_arg"
+let pnegbint_arg = "Pnegbint_arg"
+let pnegfloat_arg = "Pnegfloat_arg"
+let pnegint_arg = "Pnegint_arg"
+let pnot_arg = "Pnot_arg"
+let poffsetint_arg = "Poffsetint_arg"
+let poffsetref_arg = "Poffsetref_arg"
+let popaque_arg = "Popaque_arg"
+let porbint_arg = "Porbint_arg"
+let porint_arg = "Porint_arg"
+let praise_arg = "Praise_arg"
+let prevapply_arg = "Prevapply_arg"
+let psequand_arg = "Psequand_arg"
+let psequor_arg = "Psequor_arg"
+let psetfield_arg = "Psetfield_arg"
+let psetfield_computed_arg = "Psetfield_computed_arg"
+let psetfloatfield_arg = "Psetfloatfield_arg"
+let psetglobal_arg = "Psetglobal_arg"
+let pstring_load_16_arg = "Pstring_load_16_arg"
+let pstring_load_32_arg = "Pstring_load_32_arg"
+let pstring_load_64_arg = "Pstring_load_64_arg"
+let pbytes_load_16_arg = "Pbytes_load_16_arg"
+let pbytes_load_32_arg = "Pbytes_load_32_arg"
+let pbytes_load_64_arg = "Pbytes_load_64_arg"
+let pbytes_set_16_arg = "Pbytes_set_16_arg"
+let pbytes_set_32_arg = "Pbytes_set_32_arg"
+let pbytes_set_64_arg = "Pbytes_set_64_arg"
+let pstringlength_arg = "Pstringlength_arg"
+let pstringrefs_arg = "Pstringrefs_arg"
+let pstringrefu_arg = "Pstringrefu_arg"
+let psubbint_arg = "Psubbint_arg"
+let psubfloat_arg = "Psubfloat_arg"
+let psubint_arg = "Psubint_arg"
+let pxorbint_arg = "Pxorbint_arg"
+let pxorint_arg = "Pxorint_arg"
+let raise = "raise"
+let raise_arg = "raise_arg"
+let read_mutable = "read_mutable"
+let remove_unused_arguments = "remove_unused_arguments"
+let result = "result"
+let send_arg = "send_arg"
+let sequence = "sequence"
+let set_of_closures = "set_of_closures"
+let simplify_fv = "simplify_fv"
+let staticraise_arg = "staticraise_arg"
+let string_switch = "string_switch"
+let switch = "switch"
+let symbol = "symbol"
+let symbol_field = "symbol_field"
+let symbol_field_block = "symbol_field_block"
+let the_dead_constant = "the_dead_constant"
+let toplevel_substitution_named = "toplevel_substitution_named"
+let unbox_free_vars_of_closures = "unbox_free_vars_of_closures"
+let zero = "zero"
+
+let anon_fn_with_loc_fmt = format_of_string "anon_fn[%a]"
+let anon_fn_with_loc loc =
+ if loc = Location.none then anon_fn
+ else begin
+ Format.asprintf anon_fn_with_loc_fmt Location.print_compact loc
+ end
+
+let of_primitive : Lambda.primitive -> string = function
+ | Pidentity -> pidentity
+ | Pbytes_of_string -> pbytes_of_string
+ | Pbytes_to_string -> pbytes_to_string
+ | Pignore -> pignore
+ | Prevapply -> prevapply
+ | Pdirapply -> pdirapply
+ | Pgetglobal _ -> pgetglobal
+ | Psetglobal _ -> psetglobal
+ | Pmakeblock _ -> pmakeblock
+ | Pfield _ -> pfield
+ | Pfield_computed -> pfield_computed
+ | Psetfield _ -> psetfield
+ | Psetfield_computed _ -> psetfield_computed
+ | Pfloatfield _ -> pfloatfield
+ | Psetfloatfield _ -> psetfloatfield
+ | Pduprecord _ -> pduprecord
+ | Pccall _ -> pccall
+ | Praise _ -> praise
+ | Psequand -> psequand
+ | Psequor -> psequor
+ | Pnot -> pnot
+ | Pnegint -> pnegint
+ | Paddint -> paddint
+ | Psubint -> psubint
+ | Pmulint -> pmulint
+ | Pdivint _ -> pdivint
+ | Pmodint _ -> pmodint
+ | Pandint -> pandint
+ | Porint -> porint
+ | Pxorint -> pxorint
+ | Plslint -> plslint
+ | Plsrint -> plsrint
+ | Pasrint -> pasrint
+ | Pintcomp _ -> pintcomp
+ | Poffsetint _ -> poffsetint
+ | Poffsetref _ -> poffsetref
+ | Pintoffloat -> pintoffloat
+ | Pfloatofint -> pfloatofint
+ | Pnegfloat -> pnegfloat
+ | Pabsfloat -> pabsfloat
+ | Paddfloat -> paddfloat
+ | Psubfloat -> psubfloat
+ | Pmulfloat -> pmulfloat
+ | Pdivfloat -> pdivfloat
+ | Pfloatcomp _ -> pfloatcomp
+ | Pstringlength -> pstringlength
+ | Pstringrefu -> pstringrefu
+ | Pstringrefs -> pstringrefs
+ | Pbyteslength -> pbyteslength
+ | Pbytesrefu -> pbytesrefu
+ | Pbytessetu -> pbytessetu
+ | Pbytesrefs -> pbytesrefs
+ | Pbytessets -> pbytessets
+ | Parraylength _ -> parraylength
+ | Pmakearray _ -> pmakearray
+ | Pduparray _ -> pduparray
+ | Parrayrefu _ -> parrayrefu
+ | Parraysetu _ -> parraysetu
+ | Parrayrefs _ -> parrayrefs
+ | Parraysets _ -> parraysets
+ | Pctconst _ -> pctconst
+ | Pisint -> pisint
+ | Pisout -> pisout
+ | Pbintofint _ -> pbintofint
+ | Pintofbint _ -> pintofbint
+ | Pcvtbint _ -> pcvtbint
+ | Pnegbint _ -> pnegbint
+ | Paddbint _ -> paddbint
+ | Psubbint _ -> psubbint
+ | Pmulbint _ -> pmulbint
+ | Pdivbint _ -> pdivbint
+ | Pmodbint _ -> pmodbint
+ | Pandbint _ -> pandbint
+ | Porbint _ -> porbint
+ | Pxorbint _ -> pxorbint
+ | Plslbint _ -> plslbint
+ | Plsrbint _ -> plsrbint
+ | Pasrbint _ -> pasrbint
+ | Pbintcomp _ -> pbintcomp
+ | Pbigarrayref _ -> pbigarrayref
+ | Pbigarrayset _ -> pbigarrayset
+ | Pbigarraydim _ -> pbigarraydim
+ | Pstring_load_16 _ -> pstring_load_16
+ | Pstring_load_32 _ -> pstring_load_32
+ | Pstring_load_64 _ -> pstring_load_64
+ | Pbytes_load_16 _ -> pbytes_load_16
+ | Pbytes_load_32 _ -> pbytes_load_32
+ | Pbytes_load_64 _ -> pbytes_load_64
+ | Pbytes_set_16 _ -> pbytes_set_16
+ | Pbytes_set_32 _ -> pbytes_set_32
+ | Pbytes_set_64 _ -> pbytes_set_64
+ | Pbigstring_load_16 _ -> pbigstring_load_16
+ | Pbigstring_load_32 _ -> pbigstring_load_32
+ | Pbigstring_load_64 _ -> pbigstring_load_64
+ | Pbigstring_set_16 _ -> pbigstring_set_16
+ | Pbigstring_set_32 _ -> pbigstring_set_32
+ | Pbigstring_set_64 _ -> pbigstring_set_64
+ | Pbswap16 -> pbswap16
+ | Pbbswap _ -> pbbswap
+ | Pint_as_pointer -> pint_as_pointer
+ | Popaque -> popaque
+
+let of_primitive_arg : Lambda.primitive -> string = function
+ | Pidentity -> pidentity_arg
+ | Pbytes_of_string -> pbytes_of_string_arg
+ | Pbytes_to_string -> pbytes_to_string_arg
+ | Pignore -> pignore_arg
+ | Prevapply -> prevapply_arg
+ | Pdirapply -> pdirapply_arg
+ | Pgetglobal _ -> pgetglobal_arg
+ | Psetglobal _ -> psetglobal_arg
+ | Pmakeblock _ -> pmakeblock_arg
+ | Pfield _ -> pfield_arg
+ | Pfield_computed -> pfield_computed_arg
+ | Psetfield _ -> psetfield_arg
+ | Psetfield_computed _ -> psetfield_computed_arg
+ | Pfloatfield _ -> pfloatfield_arg
+ | Psetfloatfield _ -> psetfloatfield_arg
+ | Pduprecord _ -> pduprecord_arg
+ | Pccall _ -> pccall_arg
+ | Praise _ -> praise_arg
+ | Psequand -> psequand_arg
+ | Psequor -> psequor_arg
+ | Pnot -> pnot_arg
+ | Pnegint -> pnegint_arg
+ | Paddint -> paddint_arg
+ | Psubint -> psubint_arg
+ | Pmulint -> pmulint_arg
+ | Pdivint _ -> pdivint_arg
+ | Pmodint _ -> pmodint_arg
+ | Pandint -> pandint_arg
+ | Porint -> porint_arg
+ | Pxorint -> pxorint_arg
+ | Plslint -> plslint_arg
+ | Plsrint -> plsrint_arg
+ | Pasrint -> pasrint_arg
+ | Pintcomp _ -> pintcomp_arg
+ | Poffsetint _ -> poffsetint_arg
+ | Poffsetref _ -> poffsetref_arg
+ | Pintoffloat -> pintoffloat_arg
+ | Pfloatofint -> pfloatofint_arg
+ | Pnegfloat -> pnegfloat_arg
+ | Pabsfloat -> pabsfloat_arg
+ | Paddfloat -> paddfloat_arg
+ | Psubfloat -> psubfloat_arg
+ | Pmulfloat -> pmulfloat_arg
+ | Pdivfloat -> pdivfloat_arg
+ | Pfloatcomp _ -> pfloatcomp_arg
+ | Pstringlength -> pstringlength_arg
+ | Pstringrefu -> pstringrefu_arg
+ | Pstringrefs -> pstringrefs_arg
+ | Pbyteslength -> pbyteslength_arg
+ | Pbytesrefu -> pbytesrefu_arg
+ | Pbytessetu -> pbytessetu_arg
+ | Pbytesrefs -> pbytesrefs_arg
+ | Pbytessets -> pbytessets_arg
+ | Parraylength _ -> parraylength_arg
+ | Pmakearray _ -> pmakearray_arg
+ | Pduparray _ -> pduparray_arg
+ | Parrayrefu _ -> parrayrefu_arg
+ | Parraysetu _ -> parraysetu_arg
+ | Parrayrefs _ -> parrayrefs_arg
+ | Parraysets _ -> parraysets_arg
+ | Pctconst _ -> pctconst_arg
+ | Pisint -> pisint_arg
+ | Pisout -> pisout_arg
+ | Pbintofint _ -> pbintofint_arg
+ | Pintofbint _ -> pintofbint_arg
+ | Pcvtbint _ -> pcvtbint_arg
+ | Pnegbint _ -> pnegbint_arg
+ | Paddbint _ -> paddbint_arg
+ | Psubbint _ -> psubbint_arg
+ | Pmulbint _ -> pmulbint_arg
+ | Pdivbint _ -> pdivbint_arg
+ | Pmodbint _ -> pmodbint_arg
+ | Pandbint _ -> pandbint_arg
+ | Porbint _ -> porbint_arg
+ | Pxorbint _ -> pxorbint_arg
+ | Plslbint _ -> plslbint_arg
+ | Plsrbint _ -> plsrbint_arg
+ | Pasrbint _ -> pasrbint_arg
+ | Pbintcomp _ -> pbintcomp_arg
+ | Pbigarrayref _ -> pbigarrayref_arg
+ | Pbigarrayset _ -> pbigarrayset_arg
+ | Pbigarraydim _ -> pbigarraydim_arg
+ | Pstring_load_16 _ -> pstring_load_16_arg
+ | Pstring_load_32 _ -> pstring_load_32_arg
+ | Pstring_load_64 _ -> pstring_load_64_arg
+ | Pbytes_load_16 _ -> pbytes_load_16_arg
+ | Pbytes_load_32 _ -> pbytes_load_32_arg
+ | Pbytes_load_64 _ -> pbytes_load_64_arg
+ | Pbytes_set_16 _ -> pbytes_set_16_arg
+ | Pbytes_set_32 _ -> pbytes_set_32_arg
+ | Pbytes_set_64 _ -> pbytes_set_64_arg
+ | Pbigstring_load_16 _ -> pbigstring_load_16_arg
+ | Pbigstring_load_32 _ -> pbigstring_load_32_arg
+ | Pbigstring_load_64 _ -> pbigstring_load_64_arg
+ | Pbigstring_set_16 _ -> pbigstring_set_16_arg
+ | Pbigstring_set_32 _ -> pbigstring_set_32_arg
+ | Pbigstring_set_64 _ -> pbigstring_set_64_arg
+ | Pbswap16 -> pbswap16_arg
+ | Pbbswap _ -> pbbswap_arg
+ | Pint_as_pointer -> pint_as_pointer_arg
+ | Popaque -> popaque_arg
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Fu Yong Quah, Jane Street Europe *)
+(* *)
+(* Copyright 2017 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+type t = private string
+
+val apply_arg : t
+val apply_funct : t
+val block_symbol : t
+val block_symbol_get : t
+val block_symbol_get_field : t
+val closure : t
+val cond : t
+val cond_sequor : t
+val const_block : t
+val const_bool : t
+val const_boxed_int : t
+val const_char : t
+val const_false : t
+val const_float : t
+val const_int : t
+val const_one : t
+val const_ptr : t
+val const_ptr_one : t
+val const_ptr_zero : t
+val const_sequand : t
+val const_string : t
+val const_true : t
+val const_zero : t
+val denominator : t
+val division_by_zero : t
+val dummy : t
+val dup_func : t
+val dup_set_of_closures : t
+val const_float_array : t
+val fake_effect_symbol : t
+val for_from : t
+val for_to : t
+val from_closure : t
+val full_apply : t
+val get_symbol_field : t
+val const_immstring : t
+val const_int32 : t
+val const_int64 : t
+val is_zero : t
+val lifted_let_rec_block : t
+val meth : t
+val module_as_block : t
+val const_nativeint : t
+val new_value : t
+val numerator : t
+val obj : t
+val offsetted : t
+val partial_fun : t
+val pgetglobal : t
+val pointer : t
+val predef_exn : t
+val project_closure : t
+val raise : t
+val raise_arg : t
+val read_mutable : t
+val remove_unused_arguments : t
+val result : t
+val send_arg : t
+val sequence : t
+val set_of_closures : t
+val staticraise_arg : t
+val simplify_fv : t
+val string_switch : t
+val switch : t
+val symbol : t
+val symbol_field : t
+val symbol_field_block : t
+val the_dead_constant : t
+val toplevel_substitution_named : t
+val unbox_free_vars_of_closures : t
+val zero : t
+
+val of_primitive : Lambda.primitive -> t
+
+val of_primitive_arg : Lambda.primitive -> t
+
+val anon_fn_with_loc : Location.t -> t
: Flambda.t list
-> evaluation_order:[ `Left_to_right | `Right_to_left ]
-> create_body:(Variable.t list -> Flambda.t)
- -> name:string
+ -> name:Internal_variable_names.t
-> Flambda.t
let module Backend = (val backend) in
Backend.closure_symbol closure_id
-let make_variable_symbol prefix var =
- Symbol.create (Compilation_unit.get_current_exn ())
- (Linkage_name.create
- (prefix ^ Variable.unique_name (Variable.rename var)))
-
(** Traverse the given expression assigning symbols to [let]- and [let rec]-
bound constant variables. At the same time collect the definitions of
such variables. *)
let assign_symbol var (named : Flambda.named) =
if not (Inconstant_idents.variable var inconstants) then begin
let assign_symbol () =
- let symbol = make_variable_symbol "" var in
+ let symbol = Symbol.of_variable (Variable.rename var) in
Variable.Tbl.add var_to_symbol_tbl var symbol
in
let assign_existing_symbol = Variable.Tbl.add var_to_symbol_tbl var in
| Project_closure (s, _) ->
Symbol.Set.singleton s
+module Symbol_SCC = Strongly_connected_components.Make (Symbol)
+
let program_graph ~backend imported_symbols symbol_to_constant
(initialize_symbol_tbl :
(Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t)
)
effect_tbl graph_with_initialisation
in
- let module Symbol_SCC = Strongly_connected_components.Make (Symbol) in
let components =
Symbol_SCC.connected_components_sorted_from_roots_to_leaf
graph
assert(not (Symbol.Tbl.mem initialize_symbol_tbl sym));
(sym, Symbol.Map.find sym constant_definitions)
in
- let module Symbol_SCC = Strongly_connected_components.Make (Symbol) in
match component with
| Symbol_SCC.Has_loop l ->
let l = List.map symbol_declaration l in
end else begin
done_something := true;
let body = Flambda_utils.toplevel_substitution subst body in
- Flambda.create_function_declaration
- ~params:func_decl.params
- ~body
- ~stub:func_decl.stub
- ~dbg:func_decl.dbg
- ~inline:func_decl.inline
- ~specialise:func_decl.specialise
- ~is_a_functor:func_decl.is_a_functor
+ Flambda.update_body_of_function_declaration func_decl ~body
end)
function_decls.funs)
in
var_to_block_field_tbl
let program_symbols ~backend (program : Flambda.program) =
- let new_fake_symbol =
- let r = ref 0 in
- fun () ->
- incr r;
- Symbol.create (Compilation_unit.get_current_exn ())
- (Linkage_name.create ("fake_effect_symbol_" ^ string_of_int !r))
+ let new_fake_symbol () =
+ let var = Variable.create Internal_variable_names.fake_effect_symbol in
+ Symbol.of_variable var
in
let initialize_symbol_tbl = Symbol.Tbl.create 42 in
let effect_tbl = Symbol.Tbl.create 42 in
symbol_definition_map
Symbol.Map.empty
-let the_dead_constant_index = ref 0
-
let lift_constants (program : Flambda.program) ~backend =
let the_dead_constant =
- let index = !the_dead_constant_index in
- incr the_dead_constant_index;
- let name = Printf.sprintf "the_dead_constant_%d" index in
- Symbol.create (Compilation_unit.get_current_exn ())
- (Linkage_name.create name)
+ let var = Variable.create Internal_variable_names.the_dead_constant in
+ Symbol.of_variable var
in
let program_body : Flambda.program_body =
Let_symbol (the_dead_constant, Allocated_const (Nativeint 0n),
in
let extracted =
let expr =
+ let name = Internal_variable_names.lifted_let_rec_block in
Flambda_utils.toplevel_substitution def_substitution
(Let_rec (renamed_defs,
- Flambda_utils.name_expr ~name:"lifted_let_rec_block"
+ Flambda_utils.name_expr ~name
(Prim (Pmakeblock (0, Immutable, None),
List.map fst renamed_defs,
Debuginfo.none))))
List.map (fun decl ->
match decl with
| Block (var, _, _) | Expr (var, _) ->
- Flambda_utils.make_variable_symbol var, decl
- | Exprs (vars, _) ->
- Flambda_utils.make_variables_symbol vars, decl)
+ Symbol.of_variable (Variable.rename var), decl
+ | Exprs _ ->
+ let name = Internal_variable_names.lifted_let_rec_block in
+ let var = Variable.create name in
+ Symbol.of_variable var, decl)
accumulated.extracted_lets
in
let extracted_definitions =
let vars l = Variable.Set.of_list (List.map var l)
end
-let rename ?current_compilation_unit ?append p =
- { var = Variable.rename ?current_compilation_unit ?append p.var }
+let rename ?current_compilation_unit p =
+ { var = Variable.rename ?current_compilation_unit p.var }
let map_var f { var } = { var = f var }
(** Rename the inner variable of the parameter *)
val rename
: ?current_compilation_unit:Compilation_unit.t
- -> ?append:string
-> t
-> t
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
-let rename_var var =
- Mutable_variable.create
- (Variable.unique_name var)
(* Variable.rename var *)
(* ~current_compilation_unit:(Compilation_unit.get_current_exn ()) *)
else
let convertible_variables =
Variable.Map.mapi (fun v size ->
- Array.init size (fun _ -> rename_var v))
+ Array.init size (fun _ -> Mutable_variable.create_from_variable v))
convertible_variables
in
let convertible_variable v = Variable.Map.mem v convertible_variables in
| Some (var,size) ->
if size = 1
then begin
- let mut = Variable.create "read_mutable" in
- let new_value = Variable.create "offseted" in
+ let mut_name = Internal_variable_names.read_mutable in
+ let mut = Variable.create mut_name in
+ let new_value_name = Internal_variable_names.offsetted in
+ let new_value = Variable.create new_value_name in
let expr =
Flambda.create_let mut (Read_mutable var)
(Flambda.create_let new_value
params_for_equal_free_vars
function_decl.body
in
- Flambda.create_function_declaration
- ~params:function_decl.params
- ~body:body
- ~stub:function_decl.stub
- ~dbg:function_decl.dbg
- ~inline:function_decl.inline
- ~specialise:function_decl.specialise
- ~is_a_functor:function_decl.is_a_functor
+ Flambda.update_function_declaration function_decl
+ ~params:function_decl.params ~body:body
let rewrite_one_set_of_closures (set_of_closures : Flambda.set_of_closures) =
let back_free_vars =
Variable.rename var
~current_compilation_unit:(Compilation_unit.get_current_exn ())
-let remove_params unused (fun_decl: Flambda.function_declaration) =
+let remove_params unused (fun_decl: Flambda.function_declaration)
+ ~new_fun_var =
let unused_params, used_params =
List.partition (fun v -> Variable.Set.mem (Parameter.var v) unused)
fun_decl.params
Flambda.create_function_declaration ~params:used_params ~body
~stub:fun_decl.stub ~dbg:fun_decl.dbg ~inline:fun_decl.inline
~specialise:fun_decl.specialise ~is_a_functor:fun_decl.is_a_functor
+ ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var))
let make_stub unused var (fun_decl : Flambda.function_declaration)
~specialised_args ~additional_specialised_args =
Flambda.create_function_declaration ~params:(List.map snd args') ~body
~stub:true ~dbg:fun_decl.dbg ~inline:Default_inline
~specialise:Default_specialise ~is_a_functor:fun_decl.is_a_functor
+ ~closure_origin:fun_decl.closure_origin
in
function_decl, renamed, additional_specialised_args
~specialised_args:set_of_closures.specialised_args
~additional_specialised_args
in
- let cleaned = remove_params unused fun_decl in
+ let cleaned =
+ remove_params unused fun_decl ~new_fun_var:renamed_fun_id
+ in
Variable.Map.add fun_id stub
(Variable.Map.add renamed_fun_id cleaned funs),
additional_specialised_args
closure_id : Closure_id.t;
}
+and function_declarations = {
+ is_classic_mode : bool;
+ set_of_closures_id : Set_of_closures_id.t;
+ set_of_closures_origin : Set_of_closures_origin.t;
+ funs : function_declaration Variable.Map.t;
+}
+
+and function_body = {
+ free_variables : Variable.Set.t;
+ free_symbols : Symbol.Set.t;
+ stub : bool;
+ dbg : Debuginfo.t;
+ inline : Lambda.inline_attribute;
+ specialise : Lambda.specialise_attribute;
+ is_a_functor : bool;
+ body : Flambda.t;
+}
+
+and function_declaration = {
+ closure_origin : Closure_origin.t;
+ params : Parameter.t list;
+ function_body : function_body option;
+}
+
and value_set_of_closures = {
- function_decls : Flambda.function_declarations;
+ function_decls : function_declarations;
bound_vars : t Var_within_closure.Map.t;
- invariant_params : Variable.Set.t Variable.Map.t lazy_t;
- size : int option Variable.Map.t lazy_t;
+ free_vars : Flambda.specialised_to Variable.Map.t;
+ invariant_params : Variable.Set.t Variable.Map.t Lazy.t;
+ recursive : Variable.Set.t Lazy.t;
+ size : int option Variable.Map.t Lazy.t;
specialised_args : Flambda.specialised_to Variable.Map.t;
freshening : Freshening.Project_var.t;
direct_call_surrogates : Closure_id.t Closure_id.Map.t;
let descr t = t.descr
let print_value_set_of_closures ppf
- { function_decls = { funs }; invariant_params; freshening; _ } =
- Format.fprintf ppf "(set_of_closures:@ %a invariant_params=%a freshening=%a)"
+ { function_decls = { funs }; invariant_params; freshening; size; _ } =
+ Format.fprintf ppf "(set_of_closures:@ %a invariant_params=%a freshening=%a size=%a)"
(fun ppf -> Variable.Map.iter (fun id _ -> Variable.print ppf id)) funs
(Variable.Map.print Variable.Set.print) (Lazy.force invariant_params)
Freshening.Project_var.print freshening
+ (Variable.Map.print (fun ppf some_size ->
+ match some_size with
+ | None -> Format.fprintf ppf "None"
+ | Some size -> Format.fprintf ppf "Some %d" size))
+ (Lazy.force size)
let print_unresolved_value ppf = function
| Set_of_closures_id set ->
| Symbol symbol ->
Format.fprintf ppf "Symbol %a" Symbol.print symbol
+let print_function_declaration ppf var (f : function_declaration) =
+ let param ppf p = Variable.print ppf (Parameter.var p) in
+ let params ppf = List.iter (Format.fprintf ppf "@ %a" param) in
+ match f.function_body with
+ | None ->
+ Format.fprintf ppf "@[<2>(%a@ =@ fun@[<2>%a@])@]@ "
+ Variable.print var params f.params
+ | Some (b : function_body) ->
+ let stub = if b.stub then " *stub*" else "" in
+ let is_a_functor = if b.is_a_functor then " *functor*" else "" in
+ let inline =
+ match b.inline with
+ | Always_inline -> " *inline*"
+ | Never_inline -> " *never_inline*"
+ | Unroll _ -> " *unroll*"
+ | Default_inline -> ""
+ in
+ let specialise =
+ match b.specialise with
+ | Always_specialise -> " *specialise*"
+ | Never_specialise -> " *never_specialise*"
+ | Default_specialise -> ""
+ in
+ let print_body ppf _ =
+ Format.fprintf ppf "<Function Body>"
+ in
+ Format.fprintf ppf "@[<2>(%a%s%s%s%s@ =@ fun@[<2>%a@] ->@ @[<2><%a>@])@]@ "
+ Variable.print var stub is_a_functor inline specialise
+ params f.params
+ print_body b
+
+let print_function_declarations ppf (fd : function_declarations) =
+ let funs ppf = Variable.Map.iter (print_function_declaration ppf) in
+ Format.fprintf ppf "@[<2>(%a)@]" funs fd.funs
+
let rec print_descr ppf = function
| Value_int i -> Format.pp_print_int ppf i
| Value_char c -> Format.fprintf ppf "%c" c
}
let create_value_set_of_closures
- ~(function_decls : Flambda.function_declarations) ~bound_vars
- ~invariant_params ~specialised_args ~freshening
+ ~(function_decls : function_declarations) ~bound_vars ~free_vars
+ ~invariant_params ~recursive ~specialised_args ~freshening
~direct_call_surrogates =
let size =
lazy (
let functions = Variable.Map.keys function_decls.funs in
- Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
- let params = Parameter.Set.vars function_decl.params in
- let free_vars =
- Variable.Set.diff
- (Variable.Set.diff function_decl.free_variables params)
- functions
- in
- let num_free_vars = Variable.Set.cardinal free_vars in
- let max_size =
- Inlining_cost.maximum_interesting_size_of_function_body
- num_free_vars
- in
- Inlining_cost.lambda_smaller' function_decl.body ~than:max_size)
- function_decls.funs)
+ Variable.Map.fold
+ (fun fun_var function_decl sizes ->
+ match function_decl.function_body with
+ | None -> sizes
+ | Some function_body ->
+ let params = Parameter.Set.vars function_decl.params in
+ let free_vars =
+ Variable.Set.diff
+ (Variable.Set.diff function_body.free_variables params)
+ functions
+ in
+ let num_free_vars = Variable.Set.cardinal free_vars in
+ let max_size =
+ Inlining_cost.maximum_interesting_size_of_function_body
+ num_free_vars
+ in
+ let size =
+ Inlining_cost.lambda_smaller' function_body.body ~than:max_size
+ in
+ Variable.Map.add fun_var size sizes)
+ function_decls.funs Variable.Map.empty)
in
{ function_decls;
bound_vars;
+ free_vars;
invariant_params;
+ recursive;
size;
specialised_args;
freshening;
let make_const_int (n : int) =
let name =
match n with
- | 0 -> "const_zero"
- | 1 -> "const_one"
- | _ -> "const_int"
+ | 0 -> Internal_variable_names.const_zero
+ | 1 -> Internal_variable_names.const_one
+ | _ -> Internal_variable_names.const_int
in
name_expr_fst (make_const_int_named n) ~name
let make_const_char_named n : Flambda.named * t =
Const (Char n), value_char n
let make_const_char n =
- name_expr_fst (make_const_char_named n) ~name:"const_char"
+ let name = Internal_variable_names.const_char in
+ name_expr_fst (make_const_char_named n) ~name
let make_const_ptr_named n : Flambda.named * t =
Const (Const_pointer n), value_constptr n
let make_const_ptr (n : int) =
let name =
match n with
- | 0 -> "const_ptr_zero"
- | 1 -> "const_ptr_one"
- | _ -> "const_ptr"
+ | 0 -> Internal_variable_names.const_ptr_zero
+ | 1 -> Internal_variable_names.const_ptr_one
+ | _ -> Internal_variable_names.const_ptr
in
name_expr_fst (make_const_ptr_named n) ~name
let make_const_bool_named b : Flambda.named * t =
make_const_ptr_named (if b then 1 else 0)
let make_const_bool b =
- name_expr_fst (make_const_bool_named b) ~name:"const_bool"
+ name_expr_fst (make_const_bool_named b)
+ ~name:Internal_variable_names.const_bool
let make_const_float_named f : Flambda.named * t =
Allocated_const (Float f), value_float f
let make_const_float f =
- name_expr_fst (make_const_float_named f) ~name:"const_float"
+ name_expr_fst (make_const_float_named f)
+ ~name:Internal_variable_names.const_float
let make_const_boxed_int_named (type bi) (t:bi boxed_int) (i:bi)
: Flambda.named * t =
in
Allocated_const c, value_boxed_int t i
let make_const_boxed_int t i =
- name_expr_fst (make_const_boxed_int_named t i) ~name:"const_boxed_int"
+ name_expr_fst (make_const_boxed_int_named t i)
+ ~name:Internal_variable_names.const_boxed_int
type simplification_summary =
| Nothing_done
let const, approx = make_const_boxed_int t i in
const, Replaced_term, approx
| Value_symbol sym ->
- U.name_expr (Symbol sym) ~name:"symbol", Replaced_term, t
+ let name = Internal_variable_names.symbol in
+ U.name_expr (Symbol sym) ~name, Replaced_term, t
| Value_string _ | Value_float_array _ | Value_float None
| Value_block _ | Value_set_of_closures _ | Value_closure _
| Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ ->
| Some var when is_present_in_env var -> true, Flambda.Var var
| _ ->
match t.symbol with
- | Some (sym, None) -> true,
- U.name_expr (Symbol sym) ~name:"symbol"
+ | Some (sym, None) ->
+ let name = Internal_variable_names.symbol in
+ (true, U.name_expr (Symbol sym) ~name)
| Some (sym, Some field) ->
- true, U.name_expr (Read_symbol_field (sym, field)) ~name:"symbol_field"
+ let name = Internal_variable_names.symbol_field in
+ (true, U.name_expr (Read_symbol_field (sym, field)) ~name)
| None -> false, flam
in
let const, summary, approx = simplify t flam in
| Nativeint, Nativeint -> Nativeint.equal i1 i2
| _ -> false
+let equal_floats f1 f2 =
+ match f1, f2 with
+ | None, None -> true
+ | None, Some _ | Some _, None -> false
+ | Some f1, Some f2 -> Allocated_const.compare_floats f1 f2 = 0
+
(* Closures and set of closures descriptions cannot be merged.
let f x =
d1
| Value_extern e1, Value_extern e2 when Export_id.equal e1 e2 ->
d1
- | Value_float i, Value_float j when i = j ->
+ | Value_float i, Value_float j when equal_floats i j ->
d1
| Value_boxed_int (bi1, i1), Value_boxed_int (bi2, i2) when
equal_boxed_int bi1 i1 bi2 i2 ->
value_set_of_closures.freshening closure_id
in
try
- ignore (Flambda_utils.find_declaration closure_id
- value_set_of_closures.function_decls);
+ ignore (
+ Variable.Map.find (Closure_id.unwrap closure_id)
+ value_set_of_closures.function_decls.funs
+ );
closure_id
with Not_found ->
Misc.fatal_error (Format.asprintf
"Function %a not found in the set of closures@ %a@.%a@."
Closure_id.print closure_id
print_value_set_of_closures value_set_of_closures
- Flambda.print_function_declarations value_set_of_closures.function_decls)
+ print_function_declarations value_set_of_closures.function_decls)
type checked_approx_for_set_of_closures =
| Wrong
Cannot_be_taken
| Value_bottom ->
Cannot_be_taken
+
+let function_arity (fun_decl : function_declaration) =
+ List.length fun_decl.params
+
+let function_declaration_approx ~keep_body fun_var
+ (fun_decl : Flambda.function_declaration) =
+ let function_body =
+ if not (keep_body fun_var fun_decl) then None
+ else begin
+ Some { body = fun_decl.body;
+ stub = fun_decl.stub;
+ inline = fun_decl.inline;
+ dbg = fun_decl.dbg;
+ specialise = fun_decl.specialise;
+ is_a_functor = fun_decl.is_a_functor;
+ free_variables = fun_decl.free_variables;
+ free_symbols = fun_decl.free_symbols; }
+ end
+ in
+ { function_body;
+ params = fun_decl.params;
+ closure_origin = fun_decl.closure_origin; }
+
+let function_declarations_approx ~keep_body
+ (fun_decls : Flambda.function_declarations) =
+ let funs =
+ Variable.Map.mapi (function_declaration_approx ~keep_body) fun_decls.funs
+ in
+ { funs;
+ is_classic_mode = fun_decls.is_classic_mode;
+ set_of_closures_id = fun_decls.set_of_closures_id;
+ set_of_closures_origin = fun_decls.set_of_closures_origin; }
+
+let import_function_declarations_for_pack function_decls
+ import_set_of_closures_id import_set_of_closures_origin =
+ { set_of_closures_id =
+ import_set_of_closures_id function_decls.set_of_closures_id;
+ set_of_closures_origin =
+ import_set_of_closures_origin function_decls.set_of_closures_origin;
+ funs = function_decls.funs;
+ is_classic_mode = function_decls.is_classic_mode;
+ }
+
+let update_function_declarations function_decls ~funs =
+ let compilation_unit = Compilation_unit.get_current_exn () in
+ let is_classic_mode = function_decls.is_classic_mode in
+ let set_of_closures_id = Set_of_closures_id.create compilation_unit in
+ let set_of_closures_origin = function_decls.set_of_closures_origin in
+ { is_classic_mode;
+ set_of_closures_id;
+ set_of_closures_origin;
+ funs;
+ }
+
+let clear_function_bodies (function_decls : function_declarations) =
+ let funs =
+ Variable.Map.map (fun (fun_decl : function_declaration) ->
+ match fun_decl.function_body with
+ | None | Some { stub = true; _ } ->
+ fun_decl
+ | Some _ ->
+ { fun_decl with function_body = None })
+ function_decls.funs
+ in
+ { function_decls with funs }
+
+let update_function_declaration_body
+ (function_decl : function_declaration)
+ (f : Flambda.t -> Flambda.t) =
+ match function_decl.function_body with
+ | None -> function_decl
+ | Some function_body ->
+ let new_function_body =
+ let body = f function_body.body in
+ let free_variables = Flambda.free_variables body in
+ let free_symbols = Flambda.free_symbols body in
+ { function_body with free_variables; free_symbols; body; }
+ in
+ { function_decl with function_body = Some new_function_body }
+
+let make_closure_map input =
+ let map = ref Closure_id.Map.empty in
+ let add_set_of_closures _ (function_decls : function_declarations) =
+ Variable.Map.iter (fun var _ ->
+ let closure_id = Closure_id.wrap var in
+ map := Closure_id.Map.add closure_id function_decls !map)
+ function_decls.funs
+ in
+ Set_of_closures_id.Map.iter add_set_of_closures input;
+ !map
closure_id : Closure_id.t;
}
+and function_declarations = private {
+ is_classic_mode: bool;
+ set_of_closures_id : Set_of_closures_id.t;
+ set_of_closures_origin : Set_of_closures_origin.t;
+ funs : function_declaration Variable.Map.t;
+}
+
+and function_body = private {
+ free_variables : Variable.Set.t;
+ free_symbols : Symbol.Set.t;
+ stub : bool;
+ dbg : Debuginfo.t;
+ inline : Lambda.inline_attribute;
+ specialise : Lambda.specialise_attribute;
+ is_a_functor : bool;
+ body : Flambda.t;
+}
+
+and function_declaration = private {
+ closure_origin : Closure_origin.t;
+ params : Parameter.t list;
+ function_body : function_body option;
+}
+
+
(* CR-soon mshinwell: add support for the approximations of the results, so we
can do all of the tricky higher-order cases. *)
+(* when [is_classic_mode] is [false], functions in [function_declarations]
+ are guranteed to have function bodies (ie:
+ [function_declaration.function_body] will be of the [Some] variant).
+
+ When it [is_classic_mode] is [true], however, no gurantees about the
+ function_bodies are given.
+*)
and value_set_of_closures = private {
- function_decls : Flambda.function_declarations;
+ function_decls : function_declarations;
bound_vars : t Var_within_closure.Map.t;
- invariant_params : Variable.Set.t Variable.Map.t lazy_t;
- size : int option Variable.Map.t lazy_t;
+ free_vars : Flambda.specialised_to Variable.Map.t;
+ invariant_params : Variable.Set.t Variable.Map.t Lazy.t;
+ recursive : Variable.Set.t Lazy.t;
+ size : int option Variable.Map.t Lazy.t;
(** For functions that are very likely to be inlined, the size of the
function's body. *)
specialised_args : Flambda.specialised_to Variable.Map.t;
: Format.formatter
-> value_set_of_closures
-> unit
+val print_function_declarations
+ : Format.formatter
+ -> function_declarations
+ -> unit
+
+val function_declarations_approx
+ : keep_body:(Variable.t -> Flambda.function_declaration -> bool)
+ -> Flambda.function_declarations
+ -> function_declarations
val create_value_set_of_closures
- : function_decls:Flambda.function_declarations
+ : function_decls:function_declarations
-> bound_vars:t Var_within_closure.Map.t
+ -> free_vars:Flambda.specialised_to Variable.Map.t
-> invariant_params:Variable.Set.t Variable.Map.t lazy_t
+ -> recursive:Variable.Set.t Lazy.t
-> specialised_args:Flambda.specialised_to Variable.Map.t
-> freshening:Freshening.Project_var.t
-> direct_call_surrogates:Closure_id.t Closure_id.Map.t
(** Check that the branch is compatible with the approximation *)
val potentially_taken_const_switch_branch : t -> int -> switch_branch_selection
val potentially_taken_block_switch_branch : t -> int -> switch_branch_selection
+
+val function_arity : function_declaration -> int
+
+(** Create a set of function declarations based on another set of function
+ declarations. *)
+val update_function_declarations
+ : function_declarations
+ -> funs:function_declaration Variable.Map.t
+ -> function_declarations
+
+val import_function_declarations_for_pack
+ : function_declarations
+ -> (Set_of_closures_id.t -> Set_of_closures_id.t)
+ -> (Set_of_closures_origin.t -> Set_of_closures_origin.t)
+ -> function_declarations
+
+val update_function_declaration_body
+ : function_declaration
+ -> (Flambda.t -> Flambda.t)
+ -> function_declaration
+
+(** Creates a map from closure IDs to function declarations by iterating over
+ all sets of closures in the given map. *)
+val make_closure_map
+ : function_declarations Set_of_closures_id.Map.t
+ -> function_declarations Closure_id.Map.t
+
+val clear_function_bodies : function_declarations -> function_declarations
| Porbint kind when kind = I.kind -> eval I.logor
| Pxorbint kind when kind = I.kind -> eval I.logxor
| Pbintcomp (kind, c) when kind = I.kind ->
- S.const_comparison_expr expr c n1 n2
+ S.const_integer_comparison_expr expr c n1 n2
| _ -> expr, A.value_unknown Other, C.Benefit.zero
let simplify_binop_int (p : Lambda.primitive) (kind : I.t A.boxed_int)
new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero
else expr, A.value_boxed_int t i, C.Benefit.zero
-let const_comparison_expr expr (cmp : Lambda.comparison) x y =
+let const_integer_comparison_expr expr (cmp : Lambda.integer_comparison) x y =
(* Using the [Pervasives] comparison functions here in the compiler
coincides with the definitions of such functions in the code
compiled by the user, and is thus correct. *)
const_bool_expr expr
(match cmp with
| Ceq -> x = y
- | Cneq -> x <> y
+ | Cne -> x <> y
| Clt -> x < y
| Cgt -> x > y
| Cle -> x <= y
| Cge -> x >= y)
+
+let const_float_comparison_expr expr (cmp : Lambda.float_comparison) x y =
+ (* Using the [Pervasives] comparison functions here in the compiler
+ coincides with the definitions of such functions in the code
+ compiled by the user, and is thus correct. *)
+ const_bool_expr expr
+ (match cmp with
+ | CFeq -> x = y
+ | CFneq -> not (x = y)
+ | CFlt -> x < y
+ | CFnlt -> not (x < y)
+ | CFgt -> x > y
+ | CFngt -> not (x > y)
+ | CFle -> x <= y
+ | CFnle -> not (x <= y)
+ | CFge -> x >= y
+ | CFnge -> not (x >= y))
-> 'a
-> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t
-val const_comparison_expr
+val const_integer_comparison_expr
: Flambda.named
- -> Lambda.comparison
+ -> Lambda.integer_comparison
+ -> 'a
+ -> 'a
+ -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t
+
+val const_float_comparison_expr
+ : Flambda.named
+ -> Lambda.float_comparison
-> 'a
-> 'a
-> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t
expr, approx, C.Benefit.zero
| Pintcomp Ceq when phys_equal approxs ->
S.const_bool_expr expr true
- | Pintcomp Cneq when phys_equal approxs ->
+ | Pintcomp Cne when phys_equal approxs ->
S.const_bool_expr expr false
(* N.B. Having [not (phys_equal approxs)] would not on its own tell us
anything about whether the two values concerned are unequal. To judge
invalid. *)
| Pintcomp Ceq when phys_different approxs ->
S.const_bool_expr expr false
- | Pintcomp Cneq when phys_different approxs ->
+ | Pintcomp Cne when phys_different approxs ->
S.const_bool_expr expr true
(* If two values are structurally different we are certain they can never
be shared*)
| Plslint when shift_precond -> S.const_int_expr expr (x lsl y)
| Plsrint when shift_precond -> S.const_int_expr expr (x lsr y)
| Pasrint when shift_precond -> S.const_int_expr expr (x asr y)
- | Pintcomp cmp -> S.const_comparison_expr expr cmp x y
+ | Pintcomp cmp -> S.const_integer_comparison_expr expr cmp x y
| Pisout -> S.const_bool_expr expr (y > x || y < 0)
| _ -> expr, A.value_unknown Other, C.Benefit.zero
end
| [Value_char x; Value_char y] ->
begin match p with
- | Pintcomp cmp -> S.const_comparison_expr expr cmp x y
+ | Pintcomp cmp -> S.const_integer_comparison_expr expr cmp x y
| _ -> expr, A.value_unknown Other, C.Benefit.zero
end
| [Value_constptr x] ->
| Psubfloat -> S.const_float_expr expr (n1 -. n2)
| Pmulfloat -> S.const_float_expr expr (n1 *. n2)
| Pdivfloat -> S.const_float_expr expr (n1 /. n2)
- | Pfloatcomp c -> S.const_comparison_expr expr c n1 n2
+ | Pfloatcomp c -> S.const_float_comparison_expr expr c n1 n2
| _ -> expr, A.value_unknown Other, C.Benefit.zero
end
| [A.Value_boxed_int(A.Nativeint, n)] ->
module Transform = struct
let pass_name = "unbox-closures"
- let variable_suffix = ""
let precondition ~env ~(set_of_closures : Flambda.set_of_closures) =
!Clflags.unbox_closures
env:Inline_and_simplify_aux.Env.t
-> set_of_closures:Flambda.set_of_closures
-> fun_var:Variable.t
+ -> new_fun_var:Variable.t
-> Flambda.function_declaration
* Flambda.specialised_to Variable.Map.t)
-> set_of_closures:Flambda.set_of_closures
let pass_name = "unbox-free-vars-of-closures"
let () = Pass_wrapper.register ~pass_name
-let variable_suffix = ""
(* CR-someday mshinwell: Nearly but not quite the same as something that
Augment_specialised_args uses. *)
~definitions_indexed_by_new_inner_vars =
let body =
Flambda_utils.name_expr (Set_of_closures set_of_closures)
- ~name:pass_name
+ ~name:Internal_variable_names.unbox_free_vars_of_closures
in
Variable.Map.fold (fun new_inner_var (projection : Projection.t)
(expr, benefit) ->
"new inner" and a fresh "new outer" var, since we know
the definition is not a duplicate. *)
let projecting_from = Projection.projecting_from projection in
- let new_inner_var =
- Variable.rename projecting_from
- ~append:variable_suffix
- in
- let new_outer_var =
- Variable.rename projecting_from
- ~append:variable_suffix
- in
+ let new_inner_var = Variable.rename projecting_from in
+ let new_outer_var = Variable.rename projecting_from in
let definitions_indexed_by_new_inner_vars =
Variable.Map.add new_inner_var projection
definitions_indexed_by_new_inner_vars
module Transform = struct
let pass_name = "unbox-specialised-args"
- let variable_suffix = ""
let precondition ~env:_ ~(set_of_closures : Flambda.set_of_closures) =
!Clflags.unbox_specialised_args
env:Inline_and_simplify_aux.Env.t
-> set_of_closures:Flambda.set_of_closures
-> fun_var:Variable.t
+ -> new_fun_var:Variable.t
-> Flambda.function_declaration
* Flambda.specialised_to Variable.Map.t)
-> set_of_closures:Flambda.set_of_closures
../driver/pparse.cmi ../parsing/parse.cmi odoc_types.cmi odoc_text.cmi \
odoc_sig.cmi odoc_module.cmo odoc_misc.cmi odoc_messages.cmo \
odoc_merge.cmi odoc_global.cmi odoc_dep.cmo odoc_cross.cmi \
- odoc_comments.cmi odoc_class.cmo odoc_ast.cmi ../parsing/longident.cmi \
- ../parsing/location.cmi ../parsing/lexer.cmi ../typing/env.cmi \
- ../utils/config.cmi ../utils/clflags.cmi ../parsing/asttypes.cmi \
- odoc_analyse.cmi
+ odoc_comments.cmi odoc_class.cmo odoc_ast.cmi ../parsing/location.cmi \
+ ../parsing/lexer.cmi ../typing/env.cmi ../utils/config.cmi \
+ ../utils/clflags.cmi odoc_analyse.cmi
odoc_analyse.cmx : ../utils/warnings.cmx ../typing/types.cmx \
../typing/typemod.cmx ../typing/typedtree.cmx ../parsing/syntaxerr.cmx \
../driver/pparse.cmx ../parsing/parse.cmx odoc_types.cmx odoc_text.cmx \
odoc_sig.cmx odoc_module.cmx odoc_misc.cmx odoc_messages.cmx \
odoc_merge.cmx odoc_global.cmx odoc_dep.cmx odoc_cross.cmx \
- odoc_comments.cmx odoc_class.cmx odoc_ast.cmx ../parsing/longident.cmx \
- ../parsing/location.cmx ../parsing/lexer.cmx ../typing/env.cmx \
- ../utils/config.cmx ../utils/clflags.cmx ../parsing/asttypes.cmi \
- odoc_analyse.cmi
+ odoc_comments.cmx odoc_class.cmx odoc_ast.cmx ../parsing/location.cmx \
+ ../parsing/lexer.cmx ../typing/env.cmx ../utils/config.cmx \
+ ../utils/clflags.cmx odoc_analyse.cmi
odoc_analyse.cmi : odoc_module.cmo odoc_global.cmi
odoc_args.cmo : ../utils/warnings.cmi odoc_types.cmi odoc_texi.cmo \
odoc_messages.cmo odoc_man.cmo odoc_latex.cmo odoc_html.cmo \
ROOTDIR = ..
include $(ROOTDIR)/config/Makefile
+include $(ROOTDIR)/Makefile.common
+
OCAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
OCAMLYACC ?= $(ROOTDIR)/boot/ocamlyacc
# If they are not, then the preprocessor logic (including the
# remove_DEBUG script and the debug target) could be removed.
# If they are, it may be better to be able to enable them at run-time
-# rather than compile-time, e.g. through a -debug command-line option.
+# rather than compile-time, e.g. through a -debug command-line option.
# In the following line, "sh" is useful under Windows. Without it,
# the ./remove_DEBUG command would be executed by cmd.exe which would not
# know how to handle it.
OCAMLDOC_LIBCMXA=odoc_info.cmxa
OCAMLDOC_LIBA=odoc_info.$(A)
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)/ocamldoc
-
-INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
-
-#MANO: man ocamldoc
-INSTALL_MANODIR=$(DESTDIR)$(MANDIR)/man3
-
-INSTALL_MLIS=odoc_info.mli
-INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi)
-INSTALL_CMTS=$(INSTALL_MLIS:.mli=.cmt) $(INSTALL_MLIS:.mli=.cmti)
+OCAMLDOC_LIBMLIS=odoc_info.mli
+OCAMLDOC_LIBCMIS=$(OCAMLDOC_LIBMLIS:.mli=.cmi)
+OCAMLDOC_LIBCMTS=$(OCAMLDOC_LIBMLIS:.mli=.cmt) $(OCAMLDOC_LIBMLIS:.mli=.cmti)
ODOC_TEST=odoc_test.cmo
GENERATORS_CMOS= \
#############
INCLUDES_DEP=\
- -I $(ROOTDIR)/parsing \
-I $(ROOTDIR)/utils \
+ -I $(ROOTDIR)/parsing \
-I $(ROOTDIR)/typing \
-I $(ROOTDIR)/driver \
-I $(ROOTDIR)/bytecomp \
LIBCMXFILES = $(LIBCMOFILES:.cmo=.cmx)
LIBCMIFILES = $(LIBCMOFILES:.cmo=.cmi)
-STDLIB_MLIS=\
- ../stdlib/*.mli \
- ../parsing/*.mli \
- ../otherlibs/$(UNIXLIB)/unix.mli \
- ../otherlibs/str/str.mli \
- ../otherlibs/bigarray/bigarray.mli
.PHONY: all
all: lib exe generators manpages
# TODO: it may be good to split the following rule in several ones, e.g.
# install-programs, install-doc, install-libs
+INSTALL_MANODIR=$(INSTALL_MANDIR)/man3
+
.PHONY: install
install:
$(MKDIR) "$(INSTALL_BINDIR)"
- $(MKDIR) "$(INSTALL_LIBDIR)"
+ $(MKDIR) "$(INSTALL_LIBDIR)/ocamldoc"
$(MKDIR) "$(INSTALL_MANODIR)"
- $(CP) $(OCAMLDOC) "$(INSTALL_BINDIR)/$(OCAMLDOC)$(EXE)"
- $(CP) ocamldoc.hva *.cmi $(OCAMLDOC_LIBCMA) "$(INSTALL_LIBDIR)"
- $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_CMTS) "$(INSTALL_LIBDIR)"
- if test -d stdlib_man; then $(CP) stdlib_man/* "$(INSTALL_MANODIR)"; else : ; fi
+ $(INSTALL_PROG) $(OCAMLDOC) "$(INSTALL_BINDIR)/$(OCAMLDOC)$(EXE)"
+ $(INSTALL_DATA) \
+ ocamldoc.hva *.cmi $(OCAMLDOC_LIBCMA) \
+ "$(INSTALL_LIBDIR)/ocamldoc"
+ $(INSTALL_DATA) \
+ $(OCAMLDOC_LIBMLIS) $(OCAMLDOC_LIBCMIS) $(OCAMLDOC_LIBCMTS) \
+ "$(INSTALL_LIBDIR)/ocamldoc"
+ if test -d stdlib_man; then \
+ $(INSTALL_DATA) stdlib_man/* "$(INSTALL_MANODIR)"; \
+ else : ; fi
# Note: at the moment, $(INSTALL_MANODIR) is created even if the doc has
# not been built. This is not clean and should be changed.
.PHONY: installopt_really
installopt_really:
$(MKDIR) "$(INSTALL_BINDIR)"
- $(MKDIR) "$(INSTALL_LIBDIR)"
- $(CP) $(OCAMLDOC_OPT) "$(INSTALL_BINDIR)/$(OCAMLDOC_OPT)$(EXE)"
- $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_CMTS) "$(INSTALL_LIBDIR)"
- $(CP) ocamldoc.hva *.cmx $(OCAMLDOC_LIBA) $(OCAMLDOC_LIBCMXA) \
- "$(INSTALL_LIBDIR)"
+ $(MKDIR) "$(INSTALL_LIBDIR)/ocamldoc"
+ $(INSTALL_PROG) \
+ $(OCAMLDOC_OPT) "$(INSTALL_BINDIR)/$(OCAMLDOC_OPT)$(EXE)"
+ $(INSTALL_DATA) \
+ $(OCAMLDOC_LIBMLIS) $(OCAMLDOC_LIBCMIS) $(OCAMLDOC_LIBCMTS) \
+ "$(INSTALL_LIBDIR)/ocamldoc"
+ $(INSTALL_DATA) \
+ ocamldoc.hva *.cmx $(OCAMLDOC_LIBA) $(OCAMLDOC_LIBCMXA) \
+ "$(INSTALL_LIBDIR)/ocamldoc"
# TODO: also split into several rules
test_stdlib:
$(MKDIR) $@
$(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/stdlib.odoc -keep-code \
- ../stdlib/pervasives.ml ../stdlib/*.mli \
+ ../stdlib/*.mli \
../otherlibs/$(UNIXLIB)/unix.mli \
../otherlibs/str/str.mli
$(MKDIR) $@
$(OCAMLDOC_RUN) -texi -sort -d $@ $(INCLUDES) odoc*.ml odoc*.mli
-stdlib_man/Pervasives.3o: $(OCAMLDOC) $(STDLIB_MLIS)
+# stdlib non-prefixed :
+#######################
+SRC=$(ROOTDIR)
+include Makefile.unprefix
+
+stdlib_man/Pervasives.3o: $(OCAMLDOC) $(STDLIB_MLIS) $(STDLIB_CMIS)
$(MKDIR) stdlib_man
- $(OCAMLDOC_RUN) -man -d stdlib_man $(INCLUDES) \
- -t "OCaml library" -man-mini $(STDLIB_MLIS)
+ $(OCAMLDOC_RUN) -man -d stdlib_man -nostdlib -I stdlib_non_prefixed \
+ -t "OCaml library" -man-mini $(STDLIB_MLIS) \
+ -initially-opened-module Pervasives
-stdlib_html/Pervasives.html: $(STDLIB_MLIS)
+stdlib_html/Pervasives.html: $(OCAMLDOC) $(STDLIB_MLIS) $(STDLIB_CMIS)
$(MKDIR) stdlib_html
- $(OCAMLDOC_RUN) -d stdlib_html -html $(INCLUDES) \
- -t "OCaml library" $^
+ $(OCAMLDOC_RUN) -d stdlib_html -html -nostdlib -I stdlib_non_prefixed \
+ -t "OCaml library" $(STDLIB_MLIS) \
+ -initially-opened-module Pervasives
.PHONY: autotest_stdlib
autotest_stdlib:
$(MKDIR) $@
$(OCAMLDOC_RUN) -g autotest/odoc_test.cmo\
$(INCLUDES) -keep-code \
- ../stdlib/pervasives.ml ../stdlib/*.mli \
+ ../stdlib/*.mli \
../otherlibs/$(UNIXLIB)/unix.mli \
../otherlibs/str/str.mli
+
+# odoc rules :
+##############
+
+.PHONY: odoc
+odoc:
+ rm -rf odoc
+ $(MKDIR) odoc
+ # .cmti --> .odoc
+ for fn in ../stdlib/stdlib*.cmti; do \
+ odoc compile $(INCLUDES) --package stdlib ../stdlib/$$fn; \
+ done
+ for lib in str bigarray; do \
+ odoc compile $(INCLUDES) --package $$lib ../otherlibs/$$lib/$$lib.cmti; \
+ done
+ odoc compile $(INCLUDES) --package unix ../otherlibs/$(UNIXLIB)/unix.cmti
+ for fn in ../parsing/*.cmti; do \
+ odoc compile $(INCLUDES) --package parsing ../parsing/$$fn; \
+ done
+ # .odoc --> .html
+ odoc html $(INCLUDES) --output-dir odoc ../stdlib/stdlib.odoc
+ for lib in str bigarray $(UNIXLIB); do \
+ odoc html $(INCLUDES) --output-dir odoc ../otherlibs/$$lib/$$lib.odoc; \
+ done
+ for fn in ../parsing/*.odoc; do \
+ odoc html $(INCLUDES) --output-dir odoc $$fn; \
+ done
+ for d in odoc/*; do \
+ lib=`basename $$d`; \
+ cd $$d; \
+ echo -e The $$lib 'library.\n\nModules\n:{!modules:' * '}' > ../../index.mld; \
+ cd ../..; \
+ odoc html $(INCLUDES) --output-dir odoc --index-for=$$lib index.mld; \
+ rm -f index.mld; \
+ done
+ cp odoc_index.html odoc/index.html
+ odoc css -o odoc
+
# backup, clean and depend :
############################
rm -f odoc_parser.output odoc_text_parser.output
rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml
rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli
- rm -rf stdlib_man
+ rm -rf stdlib_man stdlib_html
rm -f generators/*.cm[taiox] generators/*.$(A) generators/*.$(O) generators/*.cmx[as]
+ rm -f stdlib_non_prefixed/*.mli stdlib_non_prefixed/*.cmi
.PHONY: depend
depend:
--- /dev/null
+#**************************************************************************
+#* *
+#* OCaml *
+#* *
+#* Florian Angeletti *
+#* *
+#* Copyright 2017 *
+#* *
+#* *
+#* All rights reserved. This file is distributed under the terms of *
+#* the GNU Lesser General Public License version 2.1, with the *
+#* special exception on linking described in the file LICENSE. *
+#* *
+#**************************************************************************
+
+
+include $(SRC)/config/Makefile
+
+P :=
+VPATH=.:$(SRC)
+include $(SRC)/stdlib/StdlibModules
+
+STDLIB_UNPREFIXED=$(SRC)/ocamldoc/stdlib_non_prefixed
+
+STDLIB_MODULES := pervasives $(filter-out stdlib,$(STDLIB_MODULES))
+PARSING_MLIS := $(wildcard $(SRC)/parsing/*.mli)
+UTILS_MLIS := $(wildcard $(SRC)/utils/*.mli)
+TYPING_MLIS := $(wildcard $(SRC)/typing/*.mli)
+BYTECOMP_MLIS := $(wildcard $(SRC)/bytecomp/*.mli)
+
+# Documented modules: stdlib + otherlib + utils(?) + parsing(for compiler-libs)
+STDLIB_MLIS=\
+ $(STDLIB_MODULES:%=%.mli) \
+ $(PARSING_MLIS:$(SRC)/parsing/%.mli=%.mli) \
+ $(UTILS_MLIS:$(SRC)/utils/%.mli=%.mli) \
+ str.mli \
+ unix.mli unixLabels.mli \
+ graphics.mli graphicsX11.mli \
+ dynlink.mli \
+ thread.mli mutex.mli condition.mli event.mli threadUnix.mli \
+ pparse.mli
+
+STDLIB_MLIS:=$(addprefix $(STDLIB_UNPREFIXED)/, $(STDLIB_MLIS))
+
+# Dependencies for the documented modules
+STDLIB_DEPS:=$(STDLIB_MLIS) \
+ $(TYPING_MLIS:$(SRC)/typing/%.mli=$(STDLIB_UNPREFIXED)/%.mli) \
+ $(BYTECOMP_MLIS:$(SRC)/bytecomp/%.mli=$(STDLIB_UNPREFIXED)/%.mli)
+
+# Add back the isolated modules in typing and bytecomp
+STDLIB_MLIS:= $(STDLIB_MLIS) \
+$(addprefix $(STDLIB_UNPREFIXED)/, typemod.mli simplif.mli)
+
+
+STDLIB_CMIS=$(STDLIB_DEPS:%.mli=%.cmi)
+
+
+# Copy mli files from the main source directory
+
+$(STDLIB_UNPREFIXED)/%.mli: $(SRC)/stdlib/%.mli
+ cp $< $@
+
+$(STDLIB_UNPREFIXED)/%.mli: $(SRC)/parsing/%.mli
+ cp $< $@
+
+$(STDLIB_UNPREFIXED)/%.mli: $(SRC)/utils/%.mli
+ cp $< $@
+
+$(STDLIB_UNPREFIXED)/%.mli: $(SRC)/otherlibs/$(UNIXLIB)/%.mli
+ sed 's/Stdlib\.//g' $< > $@
+
+$(STDLIB_UNPREFIXED)/%.mli: $(SRC)/otherlibs/str/%.mli
+ cp $< $@
+
+$(STDLIB_UNPREFIXED)/%.mli: $(SRC)/otherlibs/num/%.mli
+ cp $< $@
+
+$(STDLIB_UNPREFIXED)/%.mli: $(SRC)/otherlibs/graph/%.mli
+ cp $< $@
+
+$(STDLIB_UNPREFIXED)/%.mli: $(SRC)/otherlibs/threads/%.mli
+ cp $< $@
+
+$(STDLIB_UNPREFIXED)/%.mli: $(SRC)/otherlibs/dynlink/%.mli
+ cp $< $@
+
+$(STDLIB_UNPREFIXED)/%.mli: $(SRC)/driver/%.mli
+ cp $< $@
+
+$(STDLIB_UNPREFIXED)/%.mli: $(SRC)/typing/%.mli
+ cp $< $@
+
+$(STDLIB_UNPREFIXED)/%.mli: $(SRC)/bytecomp/%.mli
+ cp $< $@
+
+#Extract the pervasives module from stdlib.mli
+$(STDLIB_UNPREFIXED)/pervasives.mli: $(SRC)/stdlib/stdlib.mli $(STDLIB_UNPREFIXED)/extract_pervasives.awk
+ $(AWK) -f $(STDLIB_UNPREFIXED)/extract_pervasives.awk $< > $@
+
+# Build cmis file inside the STDLIB_UNPREFIXED directories
+$(STDLIB_CMIS): $(STDLIB_DEPS)
+ cd $(STDLIB_UNPREFIXED); $(MAKE) $(notdir $(STDLIB_CMIS))
then the standard library directory. *)
let init_path () =
Config.load_path :=
- "" :: List.rev (Config.standard_library :: !Clflags.include_dirs);
+ "" :: List.rev ( Clflags.std_include_dir () @ !Clflags.include_dirs);
Env.reset_cache ()
(** Return the initial environment in which compilation proceeds. *)
let initial_env () =
- let initial =
- if Config.safe_string then Env.initial_safe_string
- else if !Clflags.unsafe_string then Env.initial_unsafe_string
- else Env.initial_safe_string
- in
- let open_mod env m =
- let open Asttypes in
- let lid = {loc = Location.in_file "ocamldoc command line";
- txt = Longident.parse m } in
- snd (Typemod.type_open_ Override env lid.loc lid) in
- (* Open the list of modules given as arguments of the "-open" flag
- The list is reversed to open the modules in the left-to-right order *)
- let to_open = List.rev !Clflags.open_modules in
- let to_open =
- if Env.get_unit_name () = "Pervasives"
- then to_open
- else "Pervasives" :: to_open
+ let initially_opened_module =
+ let m = !Odoc_global.initially_opened_module in
+ if m = Env.get_unit_name () then
+ None
+ else
+ Some m
in
- List.fold_left open_mod initial to_open
+ Typemod.initial_env
+ ~loc:(Location.in_file "ocamldoc command line")
+ ~safe_string:(Config.safe_string || not !Clflags.unsafe_string)
+ ~initially_opened_module
+ ~open_implicit_modules:(List.rev !Clflags.open_modules)
(** Optionally preprocess a source file *)
let preprocess sourcefile =
let _where = Compenv.print_standard_library
let _verbose = set Clflags.verbose
let _nopervasives = set Clflags.nopervasives
+ let _dno_unique_ids = unset Clflags.unique_ids
+ let _dunique_ids = set Clflags.unique_ids
let _dsource = set Clflags.dump_source
let _dparsetree = set Clflags.dump_parsetree
let _dtypedtree = set Clflags.dump_typedtree
(** The default option list *)
let default_options = Options.list @
[
+ "-initially-opened-module", Arg.Set_string Odoc_global.initially_opened_module,
+ M.initially_opened_module;
"-text", Arg.String (fun s ->
Odoc_global.files := !Odoc_global.files @ [Odoc_global.Text_file s]),
M.option_text ;
let with_toc = ref true
let with_index = ref true
+
+let initially_opened_module = ref "Stdlib"
(** The flag which indicates if we must generate a trailer.*)
val with_trailer : bool ref
+
+(** Name of the module that is initially opened. *)
+val initially_opened_module : string ref
self#print_header b (self#inner_title in_title);
bs b"<body>\n";
self#html_of_code ~with_pre b code;
- bs b "</body></html>";
+ bs b "</body></html>\n";
Buffer.output_buffer chanout b;
close_out chanout
with
| Some _ -> "</pre>"
);
bs b "<table class=\"typetable\">\n";
- let print_one constr =
+ let print_bar () =
bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n";
bs b "<code>";
bs b (self#keyword "|");
bs b "</code></td>\n<td align=\"left\" valign=\"top\" >\n";
- bs b "<code>";
+ bs b "<code>" in
+ let print_one constr =
+ print_bar ();
bp b "<span id=\"%s\">%s</span>"
(Naming.const_target t constr)
(self#constructor constr.vc_name);
);
bs b "\n</tr>"
in
- print_concat b "\n" print_one l;
+ if l = [] then print_bar () else
+ print_concat b "\n" print_one l;
bs b "</table>\n"
| Type_record l ->
bs b "<table>\n";
List.iter f_group groups ;
bs b "</table>\n" ;
- bs b "</body>\n</html>";
+ bs b "</body>\n</html>\n";
Buffer.output_buffer chanout b;
close_out chanout
with
(* the various elements *)
List.iter (self#html_of_class_element b)
(Class.class_elements ~trans:false cl);
- bs b "</body></html>";
+ bs b "</body></html>\n";
Buffer.output_buffer chanout b;
close_out chanout;
(* the various elements *)
List.iter (self#html_of_class_element b)
(Class.class_type_elements ~trans: false clt);
- bs b "</body></html>";
+ bs b "</body></html>\n";
Buffer.output_buffer chanout b;
close_out chanout;
(self#html_of_module_element b mt.mt_name)
(Module.module_type_elements mt);
- bs b "</body></html>";
+ bs b "</body></html>\n";
Buffer.output_buffer chanout b;
close_out chanout;
(self#html_of_module_element b modu.m_name)
(Module.module_elements modu);
- bs b "</body></html>";
+ bs b "</body></html>\n";
Buffer.output_buffer chanout b;
close_out chanout;
(List.map (fun m -> m.m_name) module_list);
| Some _ -> self#html_of_info ~indent: false b info
);
- bs b "</body>\n</html>";
+ bs b "</body>\n</html>\n";
Buffer.output_buffer chanout b;
close_out chanout
with
--- /dev/null
+<!DOCTYPE html>
+<html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title>Libraries distributed with OCaml</title>
+ <link rel="stylesheet" href="odoc.css"/>
+ <meta charset="utf-8"/>
+ <meta name="viewport" content="width=device-width,initial-scale=1.0"/>
+ <meta name="generator" content="doc-ock-html v1.0.0-1-g1fc9bf0"/>
+ </head>
+ <body>
+ <p>The following libraries are distributed with the OCaml distribution.</p>
+ <br/>
+ <table class="modules">
+ <tr>
+ <td class="module"><a href="stdlib/index.html">stdlib</a></td>
+ <td class="doc">The OCaml Standard library.</td>
+ </tr>
+ <tr>
+ <td class="module"><a href="unix/index.html">unix</a></td>
+ <td class="doc">System programming.</td>
+ </tr>
+ <tr>
+ <td class="module"><a href="parsing/index.html">bigarray</a></td>
+ <td class="doc">Large, multi-dimensional, numerical arrays.</td>
+ </tr>
+ <tr>
+ <td class="module"><a href="str/index.html">str</a></td>
+ <td class="doc">Regular expressions.</td>
+ </tr>
+ <tr>
+ <td class="module"><a href="parsing/index.html">parsing</a></td>
+ <td class="doc">The OCaml compiler parsing frontend.</td>
+ </tr>
+ <tr>
+ <td class="module"><a href="num/index.html">num</a></td>
+ <td class="doc">Arbitrary precision integers (deprecated).</td>
+ </tr>
+ </table>
+ </body>
+</html>
| None | Some (Other _) -> []
end
| Type_variant l ->
+ if l = [] then (p fmt2 "@[<h 6> |"; [CodePre (flush2())]) else (
let constructors =
List.map (fun {vc_name; vc_args; vc_ret; vc_text} ->
p fmt2 "@[<h 6> | %s" vc_name ;
let l = self#latex_of_cstr_args f mod_name (vc_args,vc_ret) in
l @ (self#entry_comment f vc_text) ) l
in
- List.flatten constructors
+ List.flatten constructors)
| Type_record l ->
self#latex_of_record f mod_name l
| Type_open ->
self#man_of_text_element b
(Odoc_info.Code (Odoc_info.use_hidden_modules name))
| Odoc_info.Superscript t ->
- bs b "^{"; self#man_of_text2 b t
+ bs b "^"; self#man_of_text2 b t
| Odoc_info.Subscript t ->
- bs b "_{"; self#man_of_text2 b t
+ bs b "_"; self#man_of_text2 b t
| Odoc_info.Module_list _ ->
()
| Odoc_info.Index_list ->
merge_all ]
)
+let initially_opened_module = "<module> Name of the module that is initially opened"
+
let help = " Display this list of options"
| Types.Cty_signature cs ->
(* we delete vals and methods in order to not print them when
displaying the type *)
- let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in
+ let tnil =
+ { Types.desc = Types.Tnil ; Types.level = 0; Types.scope = None
+ ; Types.id = 0 }
+ in
Types.Cty_signature { Types.csig_self = { cs.Types.csig_self with
Types.desc = Types.Tobject (tnil, ref None) };
csig_vars = Types.Vars.empty ;
let types =
let open Types in
- { name = (fun ld -> ld.ld_id.Ident.name );
+ { name = (fun ld -> Ident.name ld.ld_id );
start = (fun ld -> Loc.start ld.ld_loc);
end_ = (fun ld -> Loc.start ld.ld_loc);
(* Beware, Loc.start is correct in the code above:
let typedtree =
let open Typedtree in
- { name = (fun ld -> ld.ld_id.Ident.name );
+ { name = (fun ld -> Ident.name ld.ld_id );
start = (fun ld -> Loc.start ld.ld_type.ctyp_loc);
end_ = (fun ld -> Loc.end_ ld.ld_type.ctyp_loc);
inline_record = begin
# respecting the cpp # line annotation conventions
echo "# 1 \"$1\""
-LC_ALL=C sed -e '/DEBUG/c\
-(* DEBUG statement removed *)' "$1"
+LC_ALL=C sed -e '/DEBUG/s/^.*$/(* DEBUG statement removed *)/' "$1"
--- /dev/null
+annot.cmi : location.cmi
+arg.cmi :
+arg_helper.cmi : map.cmi
+array.cmi : seq.cmi
+arrayLabels.cmi : seq.cmi
+ast_helper.cmi : parsetree.cmi longident.cmi location.cmi docstrings.cmi \
+ asttypes.cmi
+ast_invariants.cmi : parsetree.cmi
+ast_iterator.cmi : parsetree.cmi location.cmi
+ast_mapper.cmi : parsetree.cmi location.cmi
+asttypes.cmi : location.cmi
+attr_helper.cmi : parsetree.cmi location.cmi format.cmi asttypes.cmi
+bigarray.cmi : complex.cmi
+btype.cmi : types.cmi set.cmi path.cmi map.cmi hashtbl.cmi format.cmi \
+ asttypes.cmi
+buffer.cmi : uchar.cmi seq.cmi
+build_path_prefix_map.cmi :
+builtin_attributes.cmi : parsetree.cmi location.cmi
+bytegen.cmi : lambda.cmi instruct.cmi
+bytelibrarian.cmi : format.cmi
+bytelink.cmi : symtable.cmi format.cmi digest.cmi cmo_format.cmi
+bytepackager.cmi : ident.cmi format.cmi env.cmi
+bytes.cmi : seq.cmi
+bytesLabels.cmi : seq.cmi
+bytesections.cmi :
+callback.cmi :
+camlinternalFormat.cmi : camlinternalFormatBasics.cmi buffer.cmi
+camlinternalFormatBasics.cmi :
+camlinternalLazy.cmi :
+camlinternalMod.cmi : obj.cmi
+camlinternalOO.cmi : obj.cmi
+ccomp.cmi :
+char.cmi :
+clflags.cmi : profile.cmi misc.cmi arg.cmi
+cmi_format.cmi : types.cmi format.cmi digest.cmi
+cmo_format.cmi : tbl.cmi lambda.cmi ident.cmi digest.cmi
+cmt_format.cmi : types.cmi typedtree.cmi location.cmi env.cmi digest.cmi \
+ cmi_format.cmi
+complex.cmi :
+condition.cmi : mutex.cmi
+config.cmi :
+consistbl.cmi : digest.cmi
+ctype.cmi : types.cmi path.cmi longident.cmi ident.cmi env.cmi asttypes.cmi
+datarepr.cmi : types.cmi path.cmi ident.cmi
+depend.cmi : set.cmi parsetree.cmi map.cmi longident.cmi
+digest.cmi :
+dll.cmi :
+docstrings.cmi : parsetree.cmi location.cmi lexing.cmi lazy.cmi
+dynlink.cmi : digest.cmi
+emitcode.cmi : instruct.cmi ident.cmi cmo_format.cmi
+env.cmi : warnings.cmi types.cmi subst.cmi path.cmi misc.cmi map.cmi \
+ longident.cmi location.cmi ident.cmi format.cmi digest.cmi consistbl.cmi \
+ cmi_format.cmi asttypes.cmi
+envaux.cmi : subst.cmi path.cmi format.cmi env.cmi
+ephemeron.cmi : hashtbl.cmi
+event.cmi :
+filename.cmi :
+float.cmi : pervasives.cmi
+format.cmi : pervasives.cmi buffer.cmi
+gc.cmi :
+genlex.cmi : stream.cmi
+graphics.cmi :
+graphicsX11.cmi :
+hashtbl.cmi : seq.cmi
+ident.cmi : identifiable.cmi
+identifiable.cmi : set.cmi map.cmi hashtbl.cmi format.cmi
+includeclass.cmi : types.cmi location.cmi format.cmi env.cmi ctype.cmi
+includecore.cmi : types.cmi typedtree.cmi location.cmi ident.cmi format.cmi \
+ env.cmi
+includemod.cmi : types.cmi typedtree.cmi path.cmi location.cmi \
+ includecore.cmi ident.cmi format.cmi env.cmi ctype.cmi
+instruct.cmi : types.cmi subst.cmi location.cmi lambda.cmi ident.cmi env.cmi
+int32.cmi :
+int64.cmi :
+lambda.cmi : types.cmi primitive.cmi path.cmi location.cmi ident.cmi env.cmi \
+ asttypes.cmi
+lazy.cmi :
+lexer.cmi : parser.cmi location.cmi lexing.cmi format.cmi
+lexing.cmi :
+list.cmi : seq.cmi
+listLabels.cmi : seq.cmi
+location.cmi : warnings.cmi lexing.cmi format.cmi
+longident.cmi :
+map.cmi : seq.cmi
+marshal.cmi :
+matching.cmi : typedtree.cmi location.cmi lambda.cmi ident.cmi
+meta.cmi : obj.cmi instruct.cmi
+misc.cmi : set.cmi map.cmi hashtbl.cmi format.cmi
+moreLabels.cmi : set.cmi seq.cmi map.cmi hashtbl.cmi
+mtype.cmi : types.cmi path.cmi ident.cmi env.cmi
+mutex.cmi :
+nativeint.cmi :
+numbers.cmi : set.cmi int64.cmi identifiable.cmi
+obj.cmi : int32.cmi
+oo.cmi : camlinternalOO.cmi
+oprint.cmi : outcometree.cmi format.cmi
+outcometree.cmi : format.cmi asttypes.cmi
+parmatch.cmi : types.cmi typedtree.cmi parsetree.cmi location.cmi \
+ hashtbl.cmi env.cmi asttypes.cmi
+parse.cmi : parsetree.cmi lexing.cmi
+parser.cmi : parsetree.cmi location.cmi lexing.cmi docstrings.cmi
+parsetree.cmi : longident.cmi location.cmi asttypes.cmi
+parsing.cmi : obj.cmi lexing.cmi
+path.cmi : ident.cmi
+pervasives.cmi : camlinternalFormatBasics.cmi
+pparse.cmi : parsetree.cmi misc.cmi lexing.cmi format.cmi
+pprintast.cmi : parsetree.cmi format.cmi
+predef.cmi : types.cmi path.cmi ident.cmi
+primitive.cmi : parsetree.cmi outcometree.cmi location.cmi
+printast.cmi : parsetree.cmi format.cmi
+printexc.cmi :
+printf.cmi : buffer.cmi
+printinstr.cmi : instruct.cmi format.cmi
+printlambda.cmi : lambda.cmi format.cmi
+printpat.cmi : typedtree.cmi format.cmi asttypes.cmi
+printtyp.cmi : types.cmi path.cmi outcometree.cmi longident.cmi ident.cmi \
+ format.cmi env.cmi asttypes.cmi
+printtyped.cmi : typedtree.cmi format.cmi
+profile.cmi : format.cmi
+queue.cmi : seq.cmi
+random.cmi : nativeint.cmi int64.cmi int32.cmi
+runtimedef.cmi :
+scanf.cmi : pervasives.cmi
+semantics_of_primitives.cmi : lambda.cmi
+seq.cmi :
+set.cmi : seq.cmi
+simplif.cmi : misc.cmi location.cmi lambda.cmi ident.cmi
+sort.cmi :
+spacetime.cmi :
+stack.cmi : seq.cmi
+stdLabels.cmi : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
+ arrayLabels.cmi
+str.cmi :
+stream.cmi :
+string.cmi : seq.cmi
+stringLabels.cmi : seq.cmi
+strongly_connected_components.cmi : identifiable.cmi
+stypes.cmi : typedtree.cmi location.cmi annot.cmi
+subst.cmi : types.cmi path.cmi ident.cmi
+switch.cmi : location.cmi
+symtable.cmi : obj.cmi misc.cmi lambda.cmi ident.cmi format.cmi digest.cmi \
+ cmo_format.cmi
+syntaxerr.cmi : location.cmi format.cmi
+sys.cmi :
+targetint.cmi :
+tast_mapper.cmi : typedtree.cmi env.cmi asttypes.cmi
+tbl.cmi : format.cmi
+terminfo.cmi :
+thread.cmi : unix.cmi
+threadUnix.cmi : unix.cmi
+translattribute.cmi : typedtree.cmi parsetree.cmi location.cmi lambda.cmi
+translclass.cmi : typedtree.cmi location.cmi lambda.cmi ident.cmi format.cmi \
+ asttypes.cmi
+translcore.cmi : typedtree.cmi path.cmi location.cmi lambda.cmi ident.cmi \
+ format.cmi env.cmi asttypes.cmi
+translmod.cmi : typedtree.cmi primitive.cmi location.cmi lambda.cmi \
+ ident.cmi format.cmi
+translobj.cmi : lambda.cmi ident.cmi env.cmi
+translprim.cmi : types.cmi typedtree.cmi primitive.cmi path.cmi location.cmi \
+ lambda.cmi ident.cmi format.cmi env.cmi
+typeclass.cmi : types.cmi typedtree.cmi parsetree.cmi longident.cmi \
+ location.cmi ident.cmi format.cmi env.cmi ctype.cmi asttypes.cmi
+typecore.cmi : types.cmi typedtree.cmi path.cmi parsetree.cmi longident.cmi \
+ location.cmi ident.cmi format.cmi env.cmi asttypes.cmi annot.cmi
+typedecl.cmi : types.cmi typedtree.cmi path.cmi parsetree.cmi longident.cmi \
+ location.cmi includecore.cmi ident.cmi format.cmi env.cmi asttypes.cmi
+typedtree.cmi : types.cmi primitive.cmi path.cmi parsetree.cmi longident.cmi \
+ location.cmi ident.cmi env.cmi asttypes.cmi
+typedtreeIter.cmi : typedtree.cmi asttypes.cmi
+typedtreeMap.cmi : typedtree.cmi
+typemod.cmi : types.cmi typedtree.cmi path.cmi parsetree.cmi misc.cmi \
+ longident.cmi location.cmi includemod.cmi ident.cmi format.cmi env.cmi \
+ cmi_format.cmi asttypes.cmi
+typeopt.cmi : types.cmi typedtree.cmi path.cmi lambda.cmi env.cmi
+types.cmi : set.cmi primitive.cmi path.cmi parsetree.cmi map.cmi \
+ longident.cmi location.cmi ident.cmi asttypes.cmi
+typetexp.cmi : types.cmi typedtree.cmi path.cmi parsetree.cmi longident.cmi \
+ location.cmi includemod.cmi format.cmi env.cmi asttypes.cmi
+uchar.cmi :
+unix.cmi : bigarray.cmi
+unixLabels.cmi : unix.cmi bigarray.cmi
+untypeast.cmi : typedtree.cmi path.cmi parsetree.cmi longident.cmi \
+ location.cmi asttypes.cmi
+warnings.cmi : lexing.cmi lazy.cmi
+weak.cmi : hashtbl.cmi
--- /dev/null
+TOPDIR=../..
+include $(TOPDIR)/Makefile.tools
+
+.SUFFIXES:
+
+OCAMLDEP= $(OCAMLRUN) $(TOPDIR)/tools/ocamldep -slash
+OCAMLC_SNP= $(OCAMLRUN) $(TOPDIR)/ocamlc -nostdlib -nopervasives -I $(HERE)
+
+pervasives.cmi: pervasives.mli camlinternalFormatBasics.cmi
+ $(OCAMLC_SNP) -c $<
+
+camlinternalFormatBasics.cmi: \
+camlinternalFormatBasics.mli
+ $(OCAMLC_SNP) -c $<
+
+%.cmi: %.mli pervasives.cmi
+ $(OCAMLC_SNP) -c -open Pervasives $<
+
+depend:
+ $(OCAMLDEP) *.mli > .depend
+
+include .depend
+
+clean:
+ rm *.mli *.cmi
--- /dev/null
+#**************************************************************************
+#* *
+#* OCaml *
+#* *
+#* Jeremie Dimino, Jane Street Europe *
+#* *
+#* Copyright 2017 Jane Street Group LLC *
+#* *
+#* All rights reserved. This file is distributed under the terms of *
+#* the GNU Lesser General Public License version 2.1, with the *
+#* special exception on linking described in the file LICENSE. *
+#* *
+#**************************************************************************
+
+# This script extract the Pervasives submodule from stdlib.mli into
+# pervasives.mli, for ocamldoc
+BEGIN { state=0 }
+/^module Pervasives : sig\r?$/ && state == 0 { state=1 }
+/^end\r?$/ && state == 2 { state=3 }
+{
+ if (state == 1) state=2;
+ else if (state == 2) print
+}
../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
../byterun/caml/address_class.h ../byterun/caml/io.h \
../byterun/caml/osdeps.h
-actions.cmo : environments.cmi actions.cmi
-actions.cmx : environments.cmx actions.cmi
-actions.cmi : environments.cmi
-backends.cmo : backends.cmi
-backends.cmx : backends.cmi
-backends.cmi :
-builtin_actions.cmo : variables.cmi testlib.cmi run_command.cmi \
- ocamltest_config.cmi filetype.cmi filecompare.cmi environments.cmi \
- builtin_variables.cmi builtin_modifiers.cmi backends.cmi actions.cmi \
+ocamltest_stdlib_stubs.$(O): ocamltest_stdlib_stubs.c \
+ ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+ ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
+ ../byterun/caml/memory.h ../byterun/caml/gc.h \
+ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+ ../byterun/caml/alloc.h ../byterun/caml/signals.h \
+ ../byterun/caml/osdeps.h
+actions.cmo : result.cmi environments.cmi actions.cmi
+actions.cmx : result.cmx environments.cmx actions.cmi
+actions.cmi : result.cmi environments.cmi
+actions_helpers.cmo : variables.cmi run_command.cmi result.cmi \
+ ocamltest_stdlib.cmi filecompare.cmi environments.cmi \
+ builtin_variables.cmi actions_helpers.cmi
+actions_helpers.cmx : variables.cmx run_command.cmx result.cmx \
+ ocamltest_stdlib.cmx filecompare.cmx environments.cmx \
+ builtin_variables.cmx actions_helpers.cmi
+actions_helpers.cmi : variables.cmi result.cmi environments.cmi actions.cmi
+builtin_actions.cmo : result.cmi ocamltest_stdlib.cmi ocamltest_config.cmi \
+ environments.cmi builtin_variables.cmi actions_helpers.cmi actions.cmi \
builtin_actions.cmi
-builtin_actions.cmx : variables.cmx testlib.cmx run_command.cmx \
- ocamltest_config.cmx filetype.cmx filecompare.cmx environments.cmx \
- builtin_variables.cmx builtin_modifiers.cmx backends.cmx actions.cmx \
+builtin_actions.cmx : result.cmx ocamltest_stdlib.cmx ocamltest_config.cmx \
+ environments.cmx builtin_variables.cmx actions_helpers.cmx actions.cmx \
builtin_actions.cmi
builtin_actions.cmi : actions.cmi
-builtin_modifiers.cmo : ocamltest_config.cmi environments.cmi \
- builtin_variables.cmi builtin_modifiers.cmi
-builtin_modifiers.cmx : ocamltest_config.cmx environments.cmx \
- builtin_variables.cmx builtin_modifiers.cmi
-builtin_modifiers.cmi : environments.cmi
-builtin_tests.cmo : tests.cmi ocamltest_config.cmi builtin_actions.cmi \
- builtin_tests.cmi
-builtin_tests.cmx : tests.cmx ocamltest_config.cmx builtin_actions.cmx \
- builtin_tests.cmi
-builtin_tests.cmi : tests.cmi
builtin_variables.cmo : variables.cmi builtin_variables.cmi
builtin_variables.cmx : variables.cmx builtin_variables.cmi
builtin_variables.cmi : variables.cmi
-environments.cmo : variables.cmi environments.cmi
-environments.cmx : variables.cmx environments.cmi
+environments.cmo : variables.cmi ocamltest_stdlib.cmi environments.cmi
+environments.cmx : variables.cmx ocamltest_stdlib.cmx environments.cmi
environments.cmi : variables.cmi
-filecompare.cmo : testlib.cmi run_command.cmi filecompare.cmi
-filecompare.cmx : testlib.cmx run_command.cmx filecompare.cmi
+filecompare.cmo : run_command.cmi ocamltest_stdlib.cmi filecompare.cmi
+filecompare.cmx : run_command.cmx ocamltest_stdlib.cmx filecompare.cmi
filecompare.cmi :
-filetype.cmo : filetype.cmi
-filetype.cmx : filetype.cmi
-filetype.cmi :
main.cmo : tsl_semantics.cmi tsl_parser.cmi tsl_lexer.cmi tests.cmi \
- testlib.cmi options.cmi ocamltest_config.cmi environments.cmi \
- builtin_variables.cmi actions.cmi main.cmi
+ result.cmi options.cmi ocamltest_stdlib.cmi environments.cmi \
+ builtin_variables.cmi actions_helpers.cmi actions.cmi main.cmi
main.cmx : tsl_semantics.cmx tsl_parser.cmx tsl_lexer.cmx tests.cmx \
- testlib.cmx options.cmx ocamltest_config.cmx environments.cmx \
- builtin_variables.cmx actions.cmx main.cmi
+ result.cmx options.cmx ocamltest_stdlib.cmx environments.cmx \
+ builtin_variables.cmx actions_helpers.cmx actions.cmx main.cmi
main.cmi :
+ocaml_actions.cmo : result.cmi ocamltest_stdlib.cmi ocamltest_config.cmi \
+ ocaml_variables.cmi ocaml_toplevels.cmi ocaml_tools.cmi \
+ ocaml_modifiers.cmi ocaml_flags.cmi ocaml_filetypes.cmi ocaml_files.cmi \
+ ocaml_directories.cmi ocaml_compilers.cmi ocaml_commands.cmi \
+ ocaml_backends.cmi filecompare.cmi environments.cmi builtin_variables.cmi \
+ actions_helpers.cmi actions.cmi ocaml_actions.cmi
+ocaml_actions.cmx : result.cmx ocamltest_stdlib.cmx ocamltest_config.cmx \
+ ocaml_variables.cmx ocaml_toplevels.cmx ocaml_tools.cmx \
+ ocaml_modifiers.cmx ocaml_flags.cmx ocaml_filetypes.cmx ocaml_files.cmx \
+ ocaml_directories.cmx ocaml_compilers.cmx ocaml_commands.cmx \
+ ocaml_backends.cmx filecompare.cmx environments.cmx builtin_variables.cmx \
+ actions_helpers.cmx actions.cmx ocaml_actions.cmi
+ocaml_actions.cmi : actions.cmi
+ocaml_backends.cmo : ocaml_backends.cmi
+ocaml_backends.cmx : ocaml_backends.cmi
+ocaml_backends.cmi :
+ocaml_commands.cmo : ocaml_files.cmi ocaml_commands.cmi
+ocaml_commands.cmx : ocaml_files.cmx ocaml_commands.cmi
+ocaml_commands.cmi :
+ocaml_compilers.cmo : variables.cmi ocamltest_stdlib.cmi ocaml_variables.cmi \
+ ocaml_tools.cmi ocaml_files.cmi ocaml_commands.cmi ocaml_backends.cmi \
+ builtin_variables.cmi ocaml_compilers.cmi
+ocaml_compilers.cmx : variables.cmx ocamltest_stdlib.cmx ocaml_variables.cmx \
+ ocaml_tools.cmx ocaml_files.cmx ocaml_commands.cmx ocaml_backends.cmx \
+ builtin_variables.cmx ocaml_compilers.cmi
+ocaml_compilers.cmi : variables.cmi ocaml_tools.cmi ocaml_backends.cmi
+ocaml_directories.cmo : ocamltest_stdlib.cmi ocamltest_config.cmi \
+ ocaml_backends.cmi ocaml_directories.cmi
+ocaml_directories.cmx : ocamltest_stdlib.cmx ocamltest_config.cmx \
+ ocaml_backends.cmx ocaml_directories.cmi
+ocaml_directories.cmi : ocaml_backends.cmi
+ocaml_files.cmo : ocamltest_stdlib.cmi ocaml_files.cmi
+ocaml_files.cmx : ocamltest_stdlib.cmx ocaml_files.cmi
+ocaml_files.cmi :
+ocaml_filetypes.cmo : ocaml_backends.cmi ocaml_filetypes.cmi
+ocaml_filetypes.cmx : ocaml_backends.cmx ocaml_filetypes.cmi
+ocaml_filetypes.cmi : ocaml_backends.cmi
+ocaml_flags.cmo : ocaml_files.cmi ocaml_directories.cmi ocaml_backends.cmi \
+ ocaml_flags.cmi
+ocaml_flags.cmx : ocaml_files.cmx ocaml_directories.cmx ocaml_backends.cmx \
+ ocaml_flags.cmi
+ocaml_flags.cmi : ocaml_backends.cmi
+ocaml_modifiers.cmo : ocamltest_stdlib.cmi ocamltest_config.cmi \
+ ocaml_variables.cmi environments.cmi ocaml_modifiers.cmi
+ocaml_modifiers.cmx : ocamltest_stdlib.cmx ocamltest_config.cmx \
+ ocaml_variables.cmx environments.cmx ocaml_modifiers.cmi
+ocaml_modifiers.cmi : environments.cmi
+ocaml_tests.cmo : tests.cmi ocamltest_config.cmi ocaml_actions.cmi \
+ builtin_actions.cmi ocaml_tests.cmi
+ocaml_tests.cmx : tests.cmx ocamltest_config.cmx ocaml_actions.cmx \
+ builtin_actions.cmx ocaml_tests.cmi
+ocaml_tests.cmi : tests.cmi
+ocaml_tools.cmo : variables.cmi ocamltest_stdlib.cmi ocaml_variables.cmi \
+ ocaml_files.cmi environments.cmi actions_helpers.cmi ocaml_tools.cmi
+ocaml_tools.cmx : variables.cmx ocamltest_stdlib.cmx ocaml_variables.cmx \
+ ocaml_files.cmx environments.cmx actions_helpers.cmx ocaml_tools.cmi
+ocaml_tools.cmi : variables.cmi environments.cmi
+ocaml_toplevels.cmo : variables.cmi ocamltest_stdlib.cmi ocaml_variables.cmi \
+ ocaml_tools.cmi ocaml_files.cmi ocaml_compilers.cmi ocaml_commands.cmi \
+ ocaml_backends.cmi ocaml_toplevels.cmi
+ocaml_toplevels.cmx : variables.cmx ocamltest_stdlib.cmx ocaml_variables.cmx \
+ ocaml_tools.cmx ocaml_files.cmx ocaml_compilers.cmx ocaml_commands.cmx \
+ ocaml_backends.cmx ocaml_toplevels.cmi
+ocaml_toplevels.cmi : variables.cmi ocaml_tools.cmi ocaml_compilers.cmi \
+ ocaml_backends.cmi
+ocaml_variables.cmo : variables.cmi ocamltest_stdlib.cmi ocaml_variables.cmi
+ocaml_variables.cmx : variables.cmx ocamltest_stdlib.cmx ocaml_variables.cmi
+ocaml_variables.cmi : variables.cmi
ocamltest_config.cmo : ocamltest_config.cmi
ocamltest_config.cmx : ocamltest_config.cmi
ocamltest_config.cmi :
+ocamltest_stdlib.cmo : ocamltest_stdlib.cmi
+ocamltest_stdlib.cmx : ocamltest_stdlib.cmi
+ocamltest_stdlib.cmi :
options.cmo : tests.cmi actions.cmi options.cmi
options.cmx : tests.cmx actions.cmx options.cmi
options.cmi :
-run_command.cmo : testlib.cmi run_command.cmi
-run_command.cmx : testlib.cmx run_command.cmi
+result.cmo : result.cmi
+result.cmx : result.cmi
+result.cmi :
+run_command.cmo : ocamltest_stdlib.cmi run_command.cmi
+run_command.cmx : ocamltest_stdlib.cmx run_command.cmi
run_command.cmi :
-testlib.cmo : testlib.cmi
-testlib.cmx : testlib.cmi
-testlib.cmi :
-tests.cmo : actions.cmi tests.cmi
-tests.cmx : actions.cmx tests.cmi
-tests.cmi : environments.cmi actions.cmi
+tests.cmo : result.cmi actions.cmi tests.cmi
+tests.cmx : result.cmx actions.cmx tests.cmi
+tests.cmi : result.cmi environments.cmi actions.cmi
tsl_ast.cmo : tsl_ast.cmi
tsl_ast.cmx : tsl_ast.cmi
tsl_ast.cmi :
tsl_parser.cmo : tsl_ast.cmi tsl_parser.cmi
tsl_parser.cmx : tsl_ast.cmx tsl_parser.cmi
tsl_parser.cmi : tsl_ast.cmi
-tsl_semantics.cmo : variables.cmi tsl_ast.cmi tests.cmi testlib.cmi \
- environments.cmi actions.cmi tsl_semantics.cmi
-tsl_semantics.cmx : variables.cmx tsl_ast.cmx tests.cmx testlib.cmx \
- environments.cmx actions.cmx tsl_semantics.cmi
+tsl_semantics.cmo : variables.cmi tsl_ast.cmi tests.cmi environments.cmi \
+ actions.cmi tsl_semantics.cmi
+tsl_semantics.cmx : variables.cmx tsl_ast.cmx tests.cmx environments.cmx \
+ actions.cmx tsl_semantics.cmi
tsl_semantics.cmi : tsl_ast.cmi tests.cmi environments.cmi actions.cmi
variables.cmo : variables.cmi
variables.cmx : variables.cmi
include ../config/Makefile
ifeq "$(UNIX_OR_WIN32)" "win32"
- ocamlsrcdir := $(shell echo "$(abspath $(shell pwd)/..)"|cygpath -m -f -)
+ unix := false
+ ocamlsrcdir := $(shell echo "$(abspath $(shell pwd)/..)"|cygpath -w -f - \
+ | sed 's/\\/\\\\\\\\/g')
+ ifeq "$(wildcard ../flexdll/Makefile)" ""
+ FLEXLINK_ENV=
+ else
+ FLEXLINK_ENV=OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe"
+ endif
else
+ unix := true
ocamlsrcdir := $(abspath $(shell pwd)/..)
+ FLEXLINK_ENV=
+endif
+
+ifeq "$(TOOLCHAIN)" "msvc"
+CPP := $(CPP) 2> nul
+endif
+
+ifeq "$(WITH_OCAMLDOC)" "ocamldoc"
+WITH_OCAMLDOC := true
+else
+WITH_OCAMLDOC := false
+endif
+
+ifeq "$(WITH_DEBUGGER)" "ocamldebugger"
+WITH_OCAMLDEBUG := true
+else
+WITH_OCAMLDEBUG := false
endif
CPPFLAGS += -I../byterun -DCAML_INTERNALS
# List of source files from which ocamltest is compiled
# (all the different sorts of files are derived from this)
-sources := \
+# ocamltest has two components: its core and the OCaml "plugin"
+# which is actually built into the tool but clearly separated from its core
+
+core := \
$(run).c \
run_stubs.c \
+ ocamltest_stdlib_stubs.c \
ocamltest_config.mli ocamltest_config.ml.in \
- testlib.mli testlib.ml \
+ ocamltest_stdlib.mli ocamltest_stdlib.ml \
run_command.mli run_command.ml \
- filetype.mli filetype.ml \
filecompare.mli filecompare.ml \
- backends.mli backends.ml \
variables.mli variables.ml \
environments.mli environments.ml \
- builtin_variables.mli builtin_variables.ml \
- builtin_modifiers.mli builtin_modifiers.ml \
+ result.mli result.ml \
actions.mli actions.ml \
- builtin_actions.mli builtin_actions.ml \
tests.mli tests.ml \
- builtin_tests.mli builtin_tests.ml \
tsl_ast.mli tsl_ast.ml \
tsl_parser.mly \
tsl_lexer.mli tsl_lexer.mll \
tsl_semantics.mli tsl_semantics.ml \
+ builtin_variables.mli builtin_variables.ml \
+ actions_helpers.mli actions_helpers.ml \
+ builtin_actions.mli builtin_actions.ml
+
+ocaml_plugin := \
+ ocaml_backends.mli ocaml_backends.ml \
+ ocaml_filetypes.mli ocaml_filetypes.ml \
+ ocaml_variables.mli ocaml_variables.ml \
+ ocaml_modifiers.mli ocaml_modifiers.ml \
+ ocaml_directories.mli ocaml_directories.ml \
+ ocaml_files.mli ocaml_files.ml \
+ ocaml_flags.mli ocaml_flags.ml \
+ ocaml_commands.mli ocaml_commands.ml \
+ ocaml_tools.mli ocaml_tools.ml \
+ ocaml_compilers.mli ocaml_compilers.ml \
+ ocaml_toplevels.mli ocaml_toplevels.ml \
+ ocaml_actions.mli ocaml_actions.ml \
+ ocaml_tests.mli ocaml_tests.ml
+
+sources := $(core) $(ocaml_plugin) \
options.mli options.ml \
main.mli main.ml
native_modules := $(o_files) $(cmx_files)
-directories = ../utils ../parsing ../stdlib ../compilerlibs
+directories := ../utils ../parsing ../stdlib ../compilerlibs
-include_directories = $(addprefix -I , $(directories))
+include_directories := $(addprefix -I , $(directories))
-flags = -g -nostdlib $(include_directories) \
+flags := -g -nostdlib $(include_directories) \
-strict-sequence -safe-string -strict-formats \
-w +a-4-9-41-42-44-45-48 -warn-error A
-ifeq "$(UNIX_OR_WIN32)" "unix"
-FLEXLINK_ENV=
-else # Windows
- ifeq "$(wildcard ../flexdll/Makefile)" ""
- FLEXLINK_ENV=
- else
- FLEXLINK_ENV=OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe"
- endif
-endif
-
ocamlc := $(FLEXLINK_ENV) ../byterun/ocamlrun ../ocamlc $(flags)
ocamlopt := $(FLEXLINK_ENV) ../byterun/ocamlrun ../ocamlopt $(flags)
ocamltest_config.ml: ocamltest_config.ml.in
sed \
+ -e 's|@@AFL_INSTRUMENT@@|$(AFL_INSTRUMENT)|' \
-e 's|@@ARCH@@|$(ARCH)|' \
+ -e 's|@@SHARED_LIBRARIES@@|$(SUPPORTS_SHARED_LIBRARIES)|' \
+ -e 's|@@UNIX@@|$(unix)|' \
+ -e 's|@@SYSTEM@@|$(SYSTEM)|' \
-e 's|@@CPP@@|$(CPP)|' \
-e 's|@@OCAMLCDEFAULTFLAGS@@|$(ocamlcdefaultflags)|' \
-e 's|@@OCAMLOPTDEFAULTFLAGS@@|$(ocamloptdefaultflags)|' \
-e 's|@@OCAMLSRCDIR@@|$(ocamlsrcdir)|' \
-e 's|@@FLAMBDA@@|$(FLAMBDA)|' \
+ -e 's|@@SPACETIME@@|$(WITH_SPACETIME)|' \
-e 's|@@FORCE_SAFE_STRING@@|$(FORCE_SAFE_STRING)|' \
+ -e 's|@@FLAT_FLOAT_ARRAY@@|$(FLAT_FLOAT_ARRAY)|' \
+ -e 's|@@OCAMLDOC@@|$(WITH_OCAMLDOC)|' \
+ -e 's|@@OCAMLDEBUG@@|$(WITH_OCAMLDEBUG)|' \
$< > $@
.PHONY: clean
(* Definition of actions, basic blocks for tests *)
-type result =
- | Pass of Environments.t
- | Fail of string
- | Skip of string
+type code = out_channel -> Environments.t -> Result.t * Environments.t
-let string_of_reason prefix reason =
- if reason="" then prefix
- else prefix ^ " (" ^ reason ^ ")"
+type t = {
+ name : string;
+ body : code;
+ mutable hook : code option
+}
-let string_of_result = function
- | Pass _ -> "Pass"
- | Fail reason -> string_of_reason "Fail" reason
- | Skip reason -> string_of_reason "Skip" reason
+let action_name a = a.name
-type body = out_channel -> Environments.t -> result
+let make n c = { name = n; body = c; hook = None }
-type t = {
- action_name : string;
- action_environment : Environments.t -> Environments.t;
- action_body : body
-}
+let update action code = { action with body = code }
-let compare a1 a2 = String.compare a1.action_name a2.action_name
+let compare a1 a2 = String.compare a1.name a2.name
let (actions : (string, t) Hashtbl.t) = Hashtbl.create 10
let register action =
- Hashtbl.add actions action.action_name action
+ Hashtbl.add actions action.name action
let get_registered_actions () =
- let f _action_name action acc = action::acc in
+ let f _name action acc = action::acc in
let unsorted_actions = Hashtbl.fold f actions [] in
List.sort compare unsorted_actions
try Some (Hashtbl.find actions name)
with Not_found -> None
+let set_hook name hook =
+ let action = (Hashtbl.find actions name) in
+ action.hook <- Some hook
+
+let clear_hook name =
+ let action = (Hashtbl.find actions name) in
+ action.hook <- None
+
+let clear_all_hooks () =
+ let f _name action = action.hook <- None in
+ Hashtbl.iter f actions
+
let run log env action =
- action.action_body log env
+ let code = match action.hook with
+ | None -> action.body
+ | Some code -> code in
+ code log env
module ActionSet = Set.Make
(struct
type nonrec t = t
let compare = compare
end)
-
-let update_environment initial_env actions =
- let f act env = act.action_environment env in
- ActionSet.fold f actions initial_env
(* Definition of actions, basic blocks for tests *)
-type result =
- | Pass of Environments.t
- | Fail of string
- | Skip of string
+type code = out_channel -> Environments.t -> Result.t * Environments.t
-val string_of_result : result -> string
+type t
-type body = out_channel -> Environments.t -> result
+val action_name : t -> string
-type t = {
- action_name : string;
- action_environment : Environments.t -> Environments.t;
- action_body : body
-}
+val update : t -> code -> t
+
+val make : string -> code -> t
val compare : t -> t -> int
val lookup : string -> t option
-val run : out_channel -> Environments.t -> t -> result
+val set_hook : string -> code -> unit
+val clear_hook : string -> unit
+val clear_all_hooks : unit -> unit
-module ActionSet : Set.S with type elt = t
+val run : out_channel -> Environments.t -> t -> Result.t * Environments.t
-val update_environment : Environments.t -> ActionSet.t -> Environments.t
+module ActionSet : Set.S with type elt = t
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2016 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Helper functions when writing actions *)
+
+open Ocamltest_stdlib
+
+let pass_or_skip test pass_reason skip_reason _log env =
+ let open Result in
+ let result =
+ if test
+ then pass_with_reason pass_reason
+ else skip_with_reason skip_reason in
+ (result, env)
+
+let mkreason what commandline exitcode =
+ Printf.sprintf "%s: command\n%s\nfailed with exit code %d"
+ what commandline exitcode
+
+let testfile env =
+ match Environments.lookup Builtin_variables.test_file env with
+ | None -> assert false
+ | Some t -> t
+
+let test_source_directory env =
+ Environments.safe_lookup Builtin_variables.test_source_directory env
+
+let test_build_directory env =
+ Environments.safe_lookup Builtin_variables.test_build_directory env
+
+let test_build_directory_prefix env =
+ Environments.safe_lookup Builtin_variables.test_build_directory_prefix env
+
+let words_of_variable env variable =
+ String.words (Environments.safe_lookup variable env)
+
+let exit_status_of_variable env variable =
+ try int_of_string
+ (Environments.safe_lookup variable env)
+ with _ -> 0
+
+let files env = words_of_variable env Builtin_variables.files
+
+let setup_symlinks test_source_directory build_directory files =
+ let symlink filename =
+ let src = Filename.concat test_source_directory filename in
+ let cmd = "ln -sf " ^ src ^" " ^ build_directory in
+ Sys.run_system_command cmd in
+ let copy filename =
+ let src = Filename.concat test_source_directory filename in
+ let dst = Filename.concat build_directory filename in
+ Sys.copy_file src dst in
+ let f = if Sys.os_type="Win32" then copy else symlink in
+ Sys.make_directory build_directory;
+ List.iter f files
+
+let setup_build_env add_testfile additional_files (_log : out_channel) env =
+ let build_dir = (test_build_directory env) in
+ let some_files = additional_files @ (files env) in
+ let files =
+ if add_testfile
+ then (testfile env) :: some_files
+ else some_files in
+ setup_symlinks (test_source_directory env) build_dir files;
+ Sys.chdir build_dir;
+ (Result.pass, env)
+
+let setup_simple_build_env add_testfile additional_files log env =
+ let build_env = Environments.add
+ Builtin_variables.test_build_directory
+ (test_build_directory_prefix env) env in
+ setup_build_env add_testfile additional_files log build_env
+
+let run_cmd
+ ?(environment=[||])
+ ?(stdin_variable=Builtin_variables.stdin)
+ ?(stdout_variable=Builtin_variables.stdout)
+ ?(stderr_variable=Builtin_variables.stderr)
+ ?(append=false)
+ ?(timeout=0)
+ log env cmd
+ =
+ let log_redirection std filename =
+ if filename<>"" then
+ begin
+ Printf.fprintf log " Redirecting %s to %s \n%!" std filename
+ end in
+ let lst = List.concat (List.map String.words cmd) in
+ let quoted_lst =
+ if Sys.os_type="Win32"
+ then List.map Filename.maybe_quote lst
+ else lst in
+ let cmd' = String.concat " " quoted_lst in
+ Printf.fprintf log "Commandline: %s\n" cmd';
+ let progname = List.hd quoted_lst in
+ let arguments = Array.of_list quoted_lst in
+ let stdin_filename = Environments.safe_lookup stdin_variable env in
+ let stdout_filename = Environments.safe_lookup stdout_variable env in
+ let stderr_filename = Environments.safe_lookup stderr_variable env in
+ log_redirection "stdin" stdin_filename;
+ log_redirection "stdout" stdout_filename;
+ log_redirection "stderr" stderr_filename;
+ let systemenv =
+ Array.append
+ environment
+ (Environments.to_system_env env)
+ in
+ Run_command.run {
+ Run_command.progname = progname;
+ Run_command.argv = arguments;
+ Run_command.envp = systemenv;
+ Run_command.stdin_filename = stdin_filename;
+ Run_command.stdout_filename = stdout_filename;
+ Run_command.stderr_filename = stderr_filename;
+ Run_command.append = append;
+ Run_command.timeout = timeout;
+ Run_command.log = log
+ }
+
+let run
+ (log_message : string)
+ (redirect_output : bool)
+ (can_skip : bool)
+ (prog_variable : Variables.t)
+ (args_variable : Variables.t option)
+ (log : out_channel)
+ (env : Environments.t)
+ =
+ match Environments.lookup prog_variable env with
+ | None ->
+ let msg = Printf.sprintf "%s: variable %s is undefined"
+ log_message (Variables.name_of_variable prog_variable) in
+ (Result.fail_with_reason msg, env)
+ | Some program ->
+ let arguments = match args_variable with
+ | None -> ""
+ | Some variable -> Environments.safe_lookup variable env in
+ let commandline = [program; arguments] in
+ let what = log_message ^ " " ^ program ^ " " ^
+ begin if arguments="" then "without any argument"
+ else "with arguments " ^ arguments
+ end in
+ let env =
+ if redirect_output
+ then begin
+ let output = Environments.safe_lookup Builtin_variables.output env in
+ let env =
+ Environments.add_if_undefined Builtin_variables.stdout output env
+ in
+ Environments.add_if_undefined Builtin_variables.stderr output env
+ end else env
+ in
+ let expected_exit_status =
+ exit_status_of_variable env Builtin_variables.exit_status
+ in
+ let exit_status = run_cmd log env commandline in
+ if exit_status=expected_exit_status
+ then (Result.pass, env)
+ else begin
+ let reason = mkreason what (String.concat " " commandline) exit_status in
+ if exit_status = 125 && can_skip
+ then (Result.skip_with_reason reason, env)
+ else (Result.fail_with_reason reason, env)
+ end
+
+let run_program =
+ run
+ "Running program"
+ true
+ false
+ Builtin_variables.program
+ (Some Builtin_variables.arguments)
+
+let run_script log env =
+ let response_file = Filename.temp_file "ocamltest-" ".response" in
+ Printf.fprintf log "Script should write its response to %s\n%!"
+ response_file;
+ let scriptenv = Environments.add
+ Builtin_variables.ocamltest_response response_file env in
+ let (result, newenv) = run
+ "Running script"
+ false
+ true
+ Builtin_variables.script
+ None
+ log scriptenv in
+ if Result.is_pass result then begin
+ let modifiers = Environments.modifiers_of_file response_file in
+ let modified_env = Environments.apply_modifiers newenv modifiers in
+ (result, modified_env)
+ end else begin
+ let reason = String.trim (Sys.string_of_file response_file) in
+ let newresult = { result with Result.reason = Some reason } in
+ (newresult, newenv)
+ end
+
+let run_hook hook_name log input_env =
+ Printf.fprintf log "Entering run_hook for hook %s\n%!" hook_name;
+ let response_file = Filename.temp_file "ocamltest-" ".response" in
+ Printf.fprintf log "Hook should write its response to %s\n%!"
+ response_file;
+ let hookenv = Environments.add
+ Builtin_variables.ocamltest_response response_file input_env in
+ let systemenv =
+ Environments.to_system_env hookenv in
+ let open Run_command in
+ let settings = {
+ progname = "sh";
+ argv = [|"sh"; Filename.maybe_quote hook_name|];
+ envp = systemenv;
+ stdin_filename = "";
+ stdout_filename = "";
+ stderr_filename = "";
+ append = false;
+ timeout = 0;
+ log = log;
+ } in let exit_status = run settings in
+ match exit_status with
+ | 0 ->
+ let modifiers = Environments.modifiers_of_file response_file in
+ let modified_env = Environments.apply_modifiers hookenv modifiers in
+ (Result.pass, modified_env)
+ | _ ->
+ Printf.fprintf log "Hook returned %d" exit_status;
+ let reason = String.trim (Sys.string_of_file response_file) in
+ if exit_status=125
+ then (Result.skip_with_reason reason, hookenv)
+ else (Result.fail_with_reason reason, hookenv)
+
+let check_output kind_of_output output_variable reference_variable log
+ env =
+ let to_int = function None -> 0 | Some s -> int_of_string s in
+ let skip_lines =
+ to_int (Environments.lookup Builtin_variables.skip_header_lines env) in
+ let skip_bytes =
+ to_int (Environments.lookup Builtin_variables.skip_header_bytes env) in
+ let reference_filename = Environments.safe_lookup reference_variable env in
+ let output_filename = Environments.safe_lookup output_variable env in
+ Printf.fprintf log "Comparing %s output %s to reference %s\n%!"
+ kind_of_output output_filename reference_filename;
+ let files =
+ {
+ Filecompare.filetype = Filecompare.Text;
+ Filecompare.reference_filename = reference_filename;
+ Filecompare.output_filename = output_filename
+ } in
+ let tool =
+ Filecompare.(make_cmp_tool ~ignore:{lines=skip_lines;bytes=skip_bytes}) in
+ match Filecompare.check_file ~tool files with
+ | Filecompare.Same -> (Result.pass, env)
+ | Filecompare.Different ->
+ let diff = Filecompare.diff files in
+ let diffstr = match diff with
+ | Ok difference -> difference
+ | Error diff_file -> ("See " ^ diff_file) in
+ let reason =
+ Printf.sprintf "%s output %s differs from reference %s: \n%s\n"
+ kind_of_output output_filename reference_filename diffstr in
+ if Environments.lookup_as_bool Builtin_variables.promote env = Some true
+ then begin
+ Printf.fprintf log "Promoting %s output %s to reference %s\n%!"
+ kind_of_output output_filename reference_filename;
+ Sys.copy_file output_filename reference_filename;
+ end;
+ (Result.fail_with_reason reason, env)
+ | Filecompare.Unexpected_output ->
+ let banner = String.make 40 '=' in
+ let unexpected_output = Sys.string_of_file output_filename in
+ let unexpected_output_with_banners = Printf.sprintf
+ "%s\n%s%s\n" banner unexpected_output banner in
+ let reason = Printf.sprintf
+ "The file %s was expected to be empty because there is no \
+ reference file %s but it is not:\n%s\n"
+ output_filename reference_filename unexpected_output_with_banners in
+ (Result.fail_with_reason reason, env)
+ | Filecompare.Error (commandline, exitcode) ->
+ let reason = Printf.sprintf "The command %s failed with status %d"
+ commandline exitcode in
+ (Result.fail_with_reason reason, env)
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2016 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Helper functions when writing actions *)
+
+val pass_or_skip
+ : bool -> string -> string -> out_channel -> Environments.t
+ -> Result.t * Environments.t
+
+val mkreason : string -> string -> int -> string
+
+val testfile : Environments.t -> string
+
+val test_build_directory : Environments.t -> string
+
+val test_source_directory : Environments.t -> string
+
+val words_of_variable : Environments.t -> Variables.t -> string list
+
+val exit_status_of_variable : Environments.t -> Variables.t -> int
+
+val files : Environments.t -> string list
+
+val setup_symlinks : string -> string -> string list -> unit
+
+val setup_build_env : bool -> string list -> Actions.code
+
+val setup_simple_build_env : bool -> string list -> Actions.code
+
+val run_cmd :
+ ?environment : string array ->
+ ?stdin_variable : Variables.t ->
+ ?stdout_variable : Variables.t ->
+ ?stderr_variable : Variables.t ->
+ ?append : bool ->
+ ?timeout : int ->
+ out_channel -> Environments.t -> string list -> int
+
+val run : string -> bool -> bool -> Variables.t
+ -> Variables.t option -> Actions.code
+
+val run_program : Actions.code
+
+val run_script : Actions.code
+
+val run_hook : string -> Actions.code
+
+val check_output : string -> Variables.t -> Variables.t -> Actions.code
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
-(* *)
-(* Copyright 2016 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(* Backends of the OCaml compiler and their properties *)
-
-type t = Sys.backend_type
-
-let string_of_backend = function
- | Sys.Bytecode -> "bytecode"
- | Sys.Native -> "native"
- | Sys.Other backend_name -> backend_name
-
-(* Creates a function that returns its first argument for Bytecode, *)
-(* its second argument for Native code and fails for other backends *)
-let make_backend_function bytecode_value native_value = function
- | Sys.Bytecode -> bytecode_value
- | Sys.Native -> native_value
- | Sys.Other backend_name ->
- let error_message =
- ("Other backend " ^ backend_name ^ " not supported") in
- raise (Invalid_argument error_message)
-
-let module_extension = make_backend_function "cmo" "cmx"
-
-let library_extension = make_backend_function "cma" "cmxa"
-
-let executable_extension = make_backend_function "byte" "opt"
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
-(* *)
-(* Copyright 2016 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(* Backends of the OCaml compiler and their properties *)
-
-type t = Sys.backend_type
-
-val string_of_backend : t -> string
-
-val make_backend_function : 'a -> 'a -> t -> 'a
-
-val module_extension : t -> string
-
-val library_extension : t -> string
-
-val executable_extension : t -> string
(* Definition of a few built-in actions *)
+open Ocamltest_stdlib
open Actions
-(* Miscellaneous functions *)
-
-let env_id env = env
-
-let run_command
- ?(stdin_variable=Builtin_variables.stdin)
- ?(stdout_variable=Builtin_variables.stdout)
- ?(stderr_variable=Builtin_variables.stderr)
- ?(append=false)
- ?(timeout=0)
- log env cmd
- =
- let log_redirection std filename =
- if filename<>"" then
+let reason_with_fallback env fallback =
+ match Environments.lookup Builtin_variables.reason env with
+ | None -> fallback
+ | Some reason -> reason
+
+let pass = make
+ "pass"
+ (fun _log env ->
+ let reason = reason_with_fallback env "the pass action always succeeds" in
+ let result = Result.pass_with_reason reason in
+ (result, env))
+
+let skip = make
+ "skip"
+ (fun _log env ->
+ let reason = reason_with_fallback env "the skip action always skips" in
+ let result = Result.skip_with_reason reason in
+ (result, env))
+
+let fail = make
+ "fail"
+ (fun _log env ->
+ let reason = reason_with_fallback env "the fail action always fails" in
+ let result = Result.fail_with_reason reason in
+ (result, env))
+
+let cd = make
+ "cd"
+ (fun _log env ->
+ let cwd = Environments.safe_lookup Builtin_variables.cwd env in
begin
- Printf.fprintf log " Redirecting %s to %s \n%!" std filename
- end in
- let lst = List.concat (List.map Testlib.words cmd) in
- let quoted_lst =
- if Sys.os_type="Win32"
- then List.map Testlib.maybe_quote lst
- else lst in
- let cmd' = String.concat " " quoted_lst in
- Printf.fprintf log "Commandline: %s\n" cmd';
- let progname = List.hd quoted_lst in
- let arguments = Array.of_list quoted_lst in
- (*
- let environment =
- try [|Sys.getenv "PATH" |]
- with Not_found -> [| |] in
- *)
- let stdin_filename = Environments.safe_lookup stdin_variable env in
- let stdout_filename = Environments.safe_lookup stdout_variable env in
- let stderr_filename = Environments.safe_lookup stderr_variable env in
- log_redirection "stdin" stdin_filename;
- log_redirection "stdout" stdout_filename;
- log_redirection "stderr" stderr_filename;
- Run_command.run {
- Run_command.progname = progname;
- Run_command.argv = arguments;
- (* Run_command.envp = environment; *)
- Run_command.stdin_filename = stdin_filename;
- Run_command.stdout_filename = stdout_filename;
- Run_command.stderr_filename = stderr_filename;
- Run_command.append = append;
- Run_command.timeout = timeout;
- Run_command.log = log
- }
-
-let mkreason what commandline exitcode =
- Printf.sprintf "%s: command\n%s\nfailed with exit code %d"
- what commandline exitcode
-
-let make_file_name name ext = String.concat "." [name; ext]
-
-let make_path components = List.fold_left Filename.concat "" components
-
-(*
-let rec map_reduce_result f g init = function
- | [] -> Ok init
- | x::xs ->
- (match f x with
- | Ok fx ->
- (match map_reduce_result f g init xs with
- | Ok fxs -> Ok (g fx fxs)
- | Error _ as e -> e
- )
- | Error _ as e -> e
- )
-*)
-
-let setup_symlinks test_source_directory build_directory files =
- let symlink filename =
- let src = Filename.concat test_source_directory filename in
- let cmd = "ln -sf " ^ src ^" " ^ build_directory in
- Testlib.run_system_command cmd in
- let copy filename =
- let src = Filename.concat test_source_directory filename in
- let dst = Filename.concat build_directory filename in
- Testlib.copy_file src dst in
- let f = if Sys.os_type="Win32" then copy else symlink in
- List.iter f files
-
-let mkexe =
- if Sys.os_type="Win32"
- then fun name -> make_file_name name "exe"
- else fun name -> name
-
-(* Compilers and flags *)
-
-let ocamlsrcdir () =
- try Sys.getenv "OCAMLSRCDIR"
- with Not_found -> Ocamltest_config.ocamlsrcdir
-
-let ocamlrun ocamlsrcdir =
- let ocamlrunfile = mkexe "ocamlrun" in
- make_path [ocamlsrcdir; "byterun"; ocamlrunfile]
-
-let ocamlc ocamlsrcdir =
- make_path [ocamlsrcdir; "ocamlc"]
-
-let ocaml ocamlsrcdir =
- make_path [ocamlsrcdir; "ocaml"]
-
-let ocamlc_dot_byte ocamlsrcdir =
- let ocamlrun = ocamlrun ocamlsrcdir in
- let ocamlc = ocamlc ocamlsrcdir in
- ocamlrun ^ " " ^ ocamlc
-
-let ocamlc_dot_opt ocamlsrcdir =
- make_path [ocamlsrcdir; "ocamlc.opt"]
-
-let ocamlopt ocamlsrcdir =
- make_path [ocamlsrcdir; "ocamlopt"]
-
-let ocamlopt_dot_byte ocamlsrcdir =
- let ocamlrun = ocamlrun ocamlsrcdir in
- let ocamlopt = ocamlopt ocamlsrcdir in
- ocamlrun ^ " " ^ ocamlopt
-
-let ocamlopt_dot_opt ocamlsrcdir =
- make_path [ocamlsrcdir; "ocamlopt.opt"]
-
-let ocaml_dot_byte ocamlsrcdir =
- let ocamlrun = ocamlrun ocamlsrcdir in
- let ocaml = ocaml ocamlsrcdir in
- ocamlrun ^ " " ^ ocaml
-
-let ocaml_dot_opt ocamlsrcdir =
- make_path [ocamlsrcdir; mkexe "ocamlnat"]
-
-let cmpbyt ocamlsrcdir =
- make_path [ocamlsrcdir; "tools"; "cmpbyt"]
-
-let stdlib ocamlsrcdir =
- make_path [ocamlsrcdir; "stdlib"]
-
-let stdlib_flags ocamlsrcdir =
- let stdlib_path = stdlib ocamlsrcdir in
- "-nostdlib -I " ^ stdlib_path
-
-let c_includes ocamlsrcdir =
- make_path [ocamlsrcdir; "byterun"]
-
-let c_includes_flags ocamlsrcdir =
- let dir = c_includes ocamlsrcdir in
- "-ccopt -I" ^ dir
-
-let use_runtime backend ocamlsrcdir = match backend with
- | Sys.Bytecode ->
- let ocamlrun = ocamlrun ocamlsrcdir in
- "-use-runtime " ^ ocamlrun
- | _ -> ""
-
-(* Compiler descriptions *)
-
-type compiler_info = {
- compiler_name : string -> string;
- compiler_flags : string;
- compiler_directory : string;
- compiler_backend : Sys.backend_type;
- compiler_exit_status_variabe : Variables.t;
- compiler_reference_variable : Variables.t;
- compiler_output_variable : Variables.t
-}
-
-(* Compilers compiling byte-code programs *)
-
-let bytecode_bytecode_compiler =
-{
- compiler_name = ocamlc_dot_byte;
- compiler_flags = "";
- compiler_directory = "ocamlc.byte";
- compiler_backend = Sys.Bytecode;
- compiler_exit_status_variabe = Builtin_variables.ocamlc_byte_exit_status;
- compiler_reference_variable = Builtin_variables.compiler_reference;
- compiler_output_variable = Builtin_variables.compiler_output;
-}
-
-let bytecode_native_compiler =
-{
- compiler_name = ocamlc_dot_opt;
- compiler_flags = "";
- compiler_directory = "ocamlc.opt";
- compiler_backend = Sys.Bytecode;
- compiler_exit_status_variabe = Builtin_variables.ocamlc_opt_exit_status;
- compiler_reference_variable = Builtin_variables.compiler_reference2;
- compiler_output_variable = Builtin_variables.compiler_output2;
-}
-
-(* Compilers compiling native-code programs *)
-
-let native_bytecode_compiler =
-{
- compiler_name = ocamlopt_dot_byte;
- compiler_flags = "";
- compiler_directory = "ocamlopt.byte";
- compiler_backend = Sys.Native;
- compiler_exit_status_variabe = Builtin_variables.ocamlopt_byte_exit_status;
- compiler_reference_variable = Builtin_variables.compiler_reference;
- compiler_output_variable = Builtin_variables.compiler_output;
-}
-
-let native_native_compiler =
-{
- compiler_name = ocamlopt_dot_opt;
- compiler_flags = "";
- compiler_directory = "ocamlopt.opt";
- compiler_backend = Sys.Native;
- compiler_exit_status_variabe = Builtin_variables.ocamlopt_opt_exit_status;
- compiler_reference_variable = Builtin_variables.compiler_reference2;
- compiler_output_variable = Builtin_variables.compiler_output2;
-}
-
-(* Top-levels *)
-
-let ocaml = {
- compiler_name = ocaml_dot_byte;
- compiler_flags = "";
- compiler_directory = "ocaml";
- compiler_backend = Sys.Bytecode;
- compiler_exit_status_variabe = Builtin_variables.ocaml_byte_exit_status;
- compiler_reference_variable = Builtin_variables.compiler_reference;
- compiler_output_variable = Builtin_variables.compiler_output;
-}
-
-let ocamlnat = {
- compiler_name = ocaml_dot_opt;
- compiler_flags = "-S"; (* Keep intermediate assembly files *)
- compiler_directory = "ocamlnat";
- compiler_backend = Sys.Native;
- compiler_exit_status_variabe = Builtin_variables.ocaml_opt_exit_status;
- compiler_reference_variable = Builtin_variables.compiler_reference2;
- compiler_output_variable = Builtin_variables.compiler_output2;
-}
-
-let expected_compiler_exit_status env compiler =
- try int_of_string
- (Environments.safe_lookup compiler.compiler_exit_status_variabe env)
- with _ -> 0
-
-let compiler_reference_filename env prefix compiler =
- let compiler_reference_suffix =
- Environments.safe_lookup Builtin_variables.compiler_reference_suffix env in
- let suffix =
- if compiler_reference_suffix<>""
- then compiler_reference_suffix ^ ".reference"
- else ".reference" in
- let mk s = (make_file_name prefix s) ^suffix in
- let filename = mk compiler.compiler_directory in
- if Sys.file_exists filename then filename else
- let filename = mk (Backends.string_of_backend compiler.compiler_backend) in
- if Sys.file_exists filename then filename else
- mk "compilers"
-
-(* Extracting information from environment *)
-
-let get_backend_value_from_env env bytecode_var native_var =
- Backends.make_backend_function
- (Environments.safe_lookup bytecode_var env)
- (Environments.safe_lookup native_var env)
-
-let testfile env =
- match Environments.lookup Builtin_variables.test_file env with
- | None -> assert false
- | Some t -> t
-
-let words_of_variable variable env =
- Testlib.words (Environments.safe_lookup variable env)
-
-let modules env = words_of_variable Builtin_variables.modules env
-
-let files env = words_of_variable Builtin_variables.files env
-
-let flags env = Environments.safe_lookup Builtin_variables.flags env
-
-let libraries backend env =
- let value = Environments.safe_lookup Builtin_variables.libraries env in
- let libs = Testlib.words value in
- let extension = Backends.library_extension backend in
- let add_extension lib = make_file_name lib extension in
- String.concat " " (List.map add_extension libs)
-
-let backend_default_flags env =
- get_backend_value_from_env env
- Builtin_variables.ocamlc_default_flags
- Builtin_variables.ocamlopt_default_flags
-
-let backend_flags env =
- get_backend_value_from_env env
- Builtin_variables.ocamlc_flags
- Builtin_variables.ocamlopt_flags
-
-let test_source_directory env =
- Environments.safe_lookup Builtin_variables.test_source_directory env
-
-let test_build_directory env =
- Environments.safe_lookup Builtin_variables.test_build_directory env
-
-(*
-let action_of_filetype = function
- | Filetype.Implementation -> "Compiling implementation"
- | Filetype.Interface -> "Compiling interface"
- | Filetype.C -> "Compiling C source file"
- | Filetype.C_minus_minus -> "Processing C minus minus file"
- | Filetype.Lexer -> "Generating lexer"
- | Filetype.Grammar -> "Generating parser"
-*)
-
-let link_modules
- ocamlsrcdir compiler compilername compileroutput program_variable
- custom c_headers_flags log env modules
- =
- let backend = compiler.compiler_backend in
- let expected_exit_status = expected_compiler_exit_status env compiler in
- let executable_name = match Environments.lookup program_variable env with
- | None -> assert false
- | Some program -> program in
- let module_names =
- String.concat " " (List.map Filetype.make_filename modules) in
- let what = Printf.sprintf "Linking modules %s into %s"
- module_names executable_name in
- Printf.fprintf log "%s\n%!" what;
- let output = "-o " ^ executable_name in
- let customstr = if custom then "-custom" else "" in
- let commandline =
- [
- compilername;
- customstr;
- c_headers_flags;
- use_runtime backend ocamlsrcdir;
- stdlib_flags ocamlsrcdir;
- "-linkall";
- flags env;
- libraries backend env;
- backend_default_flags env backend;
- backend_flags env backend;
- output;
- module_names
- ] in
- let exit_status =
- run_command
- ~stdout_variable:compileroutput
- ~stderr_variable:compileroutput
- ~append:true
- log env commandline in
- if exit_status=expected_exit_status
- then Pass env
- else Fail (mkreason what (String.concat " " commandline) exit_status)
-
-let compile_program
- ocamlsrcdir compiler compilername compileroutput program_variable
- log env modules
- =
- let is_c_file (_filename, filetype) = filetype=Filetype.C in
- let has_c_file = List.exists is_c_file modules in
- let backend = compiler.compiler_backend in
- let custom = (backend = Sys.Bytecode) && has_c_file in
- let c_headers_flags =
- if has_c_file then c_includes_flags ocamlsrcdir else "" in
- link_modules
- ocamlsrcdir compiler compilername compileroutput
- program_variable custom c_headers_flags log env modules
-
-let module_has_interface directory module_name =
- let interface_name =
- Filetype.make_filename (module_name, Filetype.Interface) in
- let interface_fullpath = make_path [directory;interface_name] in
- Sys.file_exists interface_fullpath
-
-let add_module_interface directory module_description =
- match module_description with
- | (filename, Filetype.Implementation) when
- module_has_interface directory filename ->
- [(filename, Filetype.Interface); module_description]
- | _ -> [module_description]
-
-let print_module_names log description modules =
- Printf.fprintf log "%s modules: %s\n%!"
- description
- (String.concat " " (List.map Filetype.make_filename modules))
-
-let setup_build_environment
- testfile source_directory build_directory log env
- =
- let specified_modules =
- List.map Filetype.filetype ((modules env) @ [testfile]) in
- print_module_names log "Specified" specified_modules;
- let source_modules =
- Testlib.concatmap
- (add_module_interface source_directory)
- specified_modules in
- print_module_names log "Source" source_modules;
- Testlib.make_directory build_directory;
- setup_symlinks
- source_directory
- build_directory
- (List.map Filetype.make_filename source_modules);
- setup_symlinks source_directory build_directory (files env);
- Sys.chdir build_directory;
- source_modules
-
-let prepare_module (module_name, module_type) =
- match module_type with
- | Filetype.Implementation | Filetype.Interface | Filetype.C ->
- [(module_name, module_type)]
- | Filetype.C_minus_minus -> assert false
- | Filetype.Lexer -> assert false
- | Filetype.Grammar -> assert false
-
-let compile_test_program program_variable compiler log env =
- let backend = compiler.compiler_backend in
- let testfile = testfile env in
- let testfile_basename = Filename.chop_extension testfile in
- let source_directory = test_source_directory env in
- let compiler_directory_suffix =
- Environments.safe_lookup Builtin_variables.compiler_directory_suffix env in
- let compiler_directory_name =
- compiler.compiler_directory ^ compiler_directory_suffix in
- let build_directory =
- make_path [test_build_directory env; compiler_directory_name] in
- let compilerreference_prefix =
- make_path [source_directory; testfile_basename] in
- let compilerreference_filename =
- compiler_reference_filename env compilerreference_prefix compiler in
- let compiler_reference_variable = compiler.compiler_reference_variable in
- let executable_filename =
- mkexe
- (make_file_name
- testfile_basename (Backends.executable_extension backend)) in
- let executable_path = make_path [build_directory; executable_filename] in
- let compiler_output_filename =
- make_file_name compiler.compiler_directory "output" in
- let compiler_output =
- make_path [build_directory; compiler_output_filename] in
- let compiler_output_variable = compiler.compiler_output_variable in
- let newenv = Environments.add_bindings
- [
- (program_variable, executable_path);
- (compiler_reference_variable, compilerreference_filename);
- (compiler_output_variable, compiler_output);
- ] env in
- if Sys.file_exists compiler_output_filename then
- Sys.remove compiler_output_filename;
- let ocamlsrcdir = ocamlsrcdir () in
- let compilername = compiler.compiler_name ocamlsrcdir in
- let source_modules =
- setup_build_environment
- testfile source_directory build_directory log env in
- let prepared_modules =
- Testlib.concatmap prepare_module source_modules in
- compile_program
- ocamlsrcdir
- compiler
- compilername
- compiler_output_variable
- program_variable log newenv prepared_modules
-
-(* Compile actions *)
-
-let compile_bytecode_with_bytecode_compiler = {
- action_name = "compile-bytecode-with-bytecode-compiler";
- action_environment = env_id;
- action_body =
- compile_test_program
- Builtin_variables.program bytecode_bytecode_compiler
-}
-
-let compile_bytecode_with_native_compiler = {
- action_name = "compile-bytecode-with-native-compiler";
- action_environment = env_id;
- action_body =
- compile_test_program
- Builtin_variables.program2 bytecode_native_compiler
-}
-
-let compile_native_with_bytecode_compiler = {
- action_name = "compile-native-with-bytecode-compiler";
- action_environment = env_id;
- action_body =
- compile_test_program
- Builtin_variables.program native_bytecode_compiler
-}
-
-let compile_native_with_native_compiler = {
- action_name = "compile-native-with-native-compiler";
- action_environment = env_id;
- action_body =
- compile_test_program
- Builtin_variables.program2 native_native_compiler
-}
-
-let exec log_message redirect_output prog_variable args_variable log env =
- match Environments.lookup prog_variable env with
- | None ->
- let msg = Printf.sprintf "%s: variable %s is undefined"
- log_message (Variables.name_of_variable prog_variable) in
- Fail msg
- | Some program ->
- let arguments = Environments.safe_lookup args_variable env in
- let commandline = [program; arguments] in
- let what = log_message ^ " " ^ program ^ " " ^
- begin if arguments="" then "without any argument"
- else "with arguments " ^ arguments
- end in
- let output = program ^ ".output" in
- let bindings =
- [
- Builtin_variables.stdout, output;
- Builtin_variables.stderr, output
- ] in
- let execution_env =
- if redirect_output then Environments.add_bindings bindings env
- else env in
- match run_command log execution_env commandline with
- | 0 ->
- let newenv =
- if redirect_output
- then Environments.add Builtin_variables.output output env
- else env in
- Pass newenv
- | _ as exitcode ->
- if exitcode = 125
- then Skip (mkreason what (String.concat " " commandline) exitcode)
- else Fail (mkreason what (String.concat " " commandline) exitcode)
-
-let execute_program =
- exec
- "Executing program"
- true
- Builtin_variables.program
- Builtin_variables.arguments
-
-let execute = {
- action_name = "execute-program";
- action_environment = env_id;
- action_body = execute_program
-}
-
-let run_script log env =
- let testfile = testfile env in
- (* let testfile_basename = Filename.chop_extension testfile in *)
- let source_directory = test_source_directory env in
- let build_directory = test_build_directory env in
- let _modules =
- setup_build_environment
- testfile source_directory build_directory log env in
- exec
- "Running script"
- false
- Builtin_variables.script
- Builtin_variables.test_file
- log env
-
-let script = {
- action_name = "run-script";
- action_environment = env_id;
- action_body = run_script
-}
-
-let run_expect log env =
- let newenv = Environments.apply_modifiers env Builtin_modifiers.expect in
- run_script log newenv
-
-let expect = {
- action_name = "run-expect";
- action_environment = env_id;
- action_body = run_expect
-}
-
-let check_output kind_of_output output_variable reference_variable log env =
- let reference_filename = Environments.safe_lookup reference_variable env in
- let output_filename = Environments.safe_lookup output_variable env in
- Printf.fprintf log "Comparing %s output %s to reference %s\n%!"
- kind_of_output output_filename reference_filename;
- let files =
- {
- Filecompare.filetype = Filecompare.Text;
- Filecompare.reference_filename = reference_filename;
- Filecompare.output_filename = output_filename
- } in
- match Filecompare.check_file files with
- | Filecompare.Same -> Pass env
- | Filecompare.Different ->
- let diff = Filecompare.diff files in
- let diffstr = match diff with
- | Ok difference -> difference
- | Error diff_file -> ("See " ^ diff_file) in
- let reason =
- Printf.sprintf "%s output %s differs from reference %s: \n%s\n"
- kind_of_output output_filename reference_filename diffstr in
- (Actions.Fail reason)
- | Filecompare.Unexpected_output ->
- let banner = String.make 40 '=' in
- let unexpected_output = Testlib.string_of_file output_filename in
- let unexpected_output_with_banners = Printf.sprintf
- "%s\n%s%s\n" banner unexpected_output banner in
- let reason = Printf.sprintf
- "The file %s was expected to be empty because there is no \
- reference file %s but it is not:\n%s\n"
- output_filename reference_filename unexpected_output_with_banners in
- (Actions.Fail reason)
- | Filecompare.Error (commandline, exitcode) ->
- let reason = Printf.sprintf "The command %s failed with status %d"
- commandline exitcode in
- (Actions.Fail reason)
-
-let make_check_compiler_output name compiler = {
- action_name = name;
- action_environment = env_id;
- action_body =
- check_output
- "compiler"
- compiler.compiler_output_variable
- compiler.compiler_reference_variable
-}
-
-let check_ocamlc_dot_byte_output = make_check_compiler_output
- "check-ocamlc-byte-output" bytecode_bytecode_compiler
-
-let check_ocamlc_dot_opt_output = make_check_compiler_output
- "check-ocamlc-opt-output" bytecode_native_compiler
-
-let check_ocamlopt_dot_byte_output = make_check_compiler_output
- "check-ocamlopt-byte-output" native_bytecode_compiler
-
-let check_ocamlopt_dot_opt_output = make_check_compiler_output
- "check-ocamlopt-opt-output" native_native_compiler
-
-let check_program_output = {
- action_name = "check-program-output";
- action_environment = env_id;
- action_body = check_output "program"
+ try
+ Sys.chdir cwd; (Result.pass, env)
+ with _ ->
+ let reason = "Could not chidir to \"" ^ cwd ^ "\"" in
+ let result = Result.fail_with_reason reason in
+ (result, env)
+ end)
+
+let dumpenv = make
+ "dumpenv"
+ (fun log env ->
+ Environments.dump log env; (Result.pass, env))
+
+let libunix = make
+ "libunix"
+ (Actions_helpers.pass_or_skip Ocamltest_config.libunix
+ "libunix available"
+ "libunix not available")
+
+let libwin32unix = make
+ "libwin32unix"
+ (Actions_helpers.pass_or_skip (not Ocamltest_config.libunix)
+ "libwin32unix available"
+ "libwin32unix not available")
+
+let windows_OS = "Windows_NT"
+
+let get_OS () = Sys.safe_getenv "OS"
+
+let windows = make
+ "windows"
+ (Actions_helpers.pass_or_skip (get_OS () = windows_OS)
+ "running on Windows"
+ "not running on Windows")
+
+let not_windows = make
+ "not-windows"
+ (Actions_helpers.pass_or_skip (get_OS () <> windows_OS)
+ "not running on Windows"
+ "running on Windows")
+
+let bsd_system = "bsd_elf"
+
+let bsd = make
+ "bsd"
+ (Actions_helpers.pass_or_skip (Ocamltest_config.system = bsd_system)
+ "on a BSD system"
+ "not on a BSD system")
+
+let not_bsd = make
+ "not-bsd"
+ (Actions_helpers.pass_or_skip (Ocamltest_config.system <> bsd_system)
+ "not on a BSD system"
+ "on a BSD system")
+
+let arch32 = make
+ "arch32"
+ (Actions_helpers.pass_or_skip (Sys.word_size = 32)
+ "32-bit architecture"
+ "non-32-bit architecture")
+
+let arch64 = make
+ "arch64"
+ (Actions_helpers.pass_or_skip (Sys.word_size = 64)
+ "64-bit architecture"
+ "non-64-bit architecture")
+
+let has_symlink = make
+ "has_symlink"
+ (Actions_helpers.pass_or_skip (Sys.has_symlink () )
+ "symlinks available"
+ "symlinks not available")
+
+let setup_build_env = make
+ "setup-build-env"
+ (Actions_helpers.setup_build_env true [])
+
+let setup_simple_build_env = make
+ "setup-simple-build-env"
+ (Actions_helpers.setup_simple_build_env true [])
+
+let run = make
+ "run"
+ Actions_helpers.run_program
+
+let script = make
+ "script"
+ Actions_helpers.run_script
+
+let check_program_output = make
+ "check-program-output"
+ (Actions_helpers.check_output "program"
Builtin_variables.output
- Builtin_variables.reference
-}
-
-(*
-let comparison_start_address portable_executable_filename =
- let portable_executalbe_signature = "PE\000\000" in
- let signature_length = String.length portable_executalbe_signature in
- let address_length = 4 in
- let start_address = 0x3c in
- let ic = open_in portable_executable_filename in
- seek_in ic start_address;
- let portable_executable_signature_address_str =
- really_input_string ic address_length in
- let b0 = int_of_char portable_executable_signature_address_str.[0] in
- let b1 = int_of_char portable_executable_signature_address_str.[1] in
- let b2 = int_of_char portable_executable_signature_address_str.[2] in
- let b3 = int_of_char portable_executable_signature_address_str.[3] in
- let signature_address =
- b0 +
- b1 * 256 +
- b2 * 256 * 256 +
- b3 * 256 * 256 * 256 in
- seek_in ic signature_address;
- let signature =
- really_input_string ic signature_length in
- if signature<>portable_executalbe_signature
- then failwith
- (portable_executable_filename ^ " does not contain the PE signature");
- let result = signature_address + 12 in
- (* 12 is 4-bytes signature, 2-bytes machine type, *)
- (* 2-bytes number of sections, 4-bytes timestamp *)
- close_in ic;
- result
-*)
+ Builtin_variables.reference)
-let compare_programs backend comparison_tool log env =
- let program = Environments.safe_lookup Builtin_variables.program env in
- let program2 = Environments.safe_lookup Builtin_variables.program2 env in
- let what = Printf.sprintf "Comparing %s programs %s and %s"
- (Backends.string_of_backend backend) program program2 in
- Printf.fprintf log "%s\n%!" what;
- let files = {
- Filecompare.filetype = Filecompare.Binary;
- Filecompare.reference_filename = program;
- Filecompare.output_filename = program2
- } in
- if Ocamltest_config.flambda && backend = Sys.Native
- then begin
- Printf.fprintf log
- "flambda temporarily disables comparison of native programs";
- Pass env
- end else if backend = Sys.Native && (Sys.os_type="Win32" || Sys.os_type="Cygwin")
- then begin
- Printf.fprintf log
- "comparison of native programs temporarily disabled under Windows";
- Pass env
- end else begin
- let comparison_tool =
- if backend=Sys.Native && (Sys.os_type="Win32" || Sys.os_type="Cygwin")
- then
- let bytes_to_ignore = 512 (* comparison_start_address program *) in
- Filecompare.make_cmp_tool bytes_to_ignore
- else comparison_tool in
- match Filecompare.compare_files ~tool:comparison_tool files with
- | Filecompare.Same -> Pass env
- | Filecompare.Different ->
- let reason = Printf.sprintf "Files %s and %s are different"
- program program2 in
- Fail reason
- | Filecompare.Unexpected_output -> assert false
- | Filecompare.Error (commandline, exitcode) ->
- let reason = mkreason what commandline exitcode in
- Fail reason
- end
-
-let make_bytecode_programs_comparison_tool ocamlsrcdir =
- let ocamlrun = ocamlrun ocamlsrcdir in
- let cmpbyt = cmpbyt ocamlsrcdir in
- let tool_name = ocamlrun ^ " " ^ cmpbyt in
- Filecompare.make_comparison_tool tool_name ""
-
-let native_programs_comparison_tool = Filecompare.default_comparison_tool
-
-let compare_bytecode_programs_body log env =
- let ocamlsrcdir = ocamlsrcdir () in
- let bytecode_programs_comparison_tool =
- make_bytecode_programs_comparison_tool ocamlsrcdir in
- compare_programs Sys.Bytecode bytecode_programs_comparison_tool log env
-
-let compare_bytecode_programs = {
- action_name = "compare-bytecode-programs";
- action_environment = env_id;
- action_body = compare_bytecode_programs_body
-}
-
-let compare_native_programs = {
- action_name = "compare-native-programs";
- action_environment = env_id;
- action_body = compare_programs Sys.Native native_programs_comparison_tool
-}
-
-let run_test_program_in_toplevel toplevel log env =
- let testfile = testfile env in
- let testfile_basename = Filename.chop_extension testfile in
- let expected_exit_status = expected_compiler_exit_status env toplevel in
- let what =
- Printf.sprintf "Running %s in %s toplevel (expected exit status: %d)"
- testfile
- (Backends.string_of_backend toplevel.compiler_backend)
- expected_exit_status in
- Printf.fprintf log "%s\n%!" what;
- let source_directory = test_source_directory env in
- let compiler_directory_suffix =
- Environments.safe_lookup Builtin_variables.compiler_directory_suffix env in
- let compiler_directory_name =
- toplevel.compiler_directory ^ compiler_directory_suffix in
- let build_directory =
- make_path [test_build_directory env; compiler_directory_name] in
- let _modules =
- setup_build_environment
- testfile source_directory build_directory log env in
- let compilerreference_prefix =
- make_path [source_directory; testfile_basename] in
- let compilerreference_filename =
- compiler_reference_filename env compilerreference_prefix toplevel in
- let compiler_reference_variable = toplevel.compiler_reference_variable in
- let compiler_output_filename =
- make_file_name toplevel.compiler_directory "output" in
- let compiler_output =
- make_path [build_directory; compiler_output_filename] in
- let compiler_output_variable = toplevel.compiler_output_variable in
- let newenv = Environments.add_bindings
- [
- (compiler_reference_variable, compilerreference_filename);
- (compiler_output_variable, compiler_output);
- ] env in
- if Sys.file_exists compiler_output_filename then
- Sys.remove compiler_output_filename;
- let ocamlsrcdir = ocamlsrcdir () in
- let toplevel_name = toplevel.compiler_name ocamlsrcdir in
- let toplevel_default_flags = "-noinit -no-version -noprompt" in
- let commandline =
+let initialize_test_exit_status_variables _log env =
+ Environments.add_bindings
[
- toplevel_name;
- toplevel_default_flags;
- toplevel.compiler_flags;
- stdlib_flags ocamlsrcdir;
- flags env;
- ] in
- let exit_status =
- run_command
- ~stdin_variable:Builtin_variables.test_file
- ~stdout_variable:compiler_output_variable
- ~stderr_variable:compiler_output_variable
- log newenv commandline in
- if exit_status=expected_exit_status
- then Pass newenv
- else Fail (mkreason what (String.concat " " commandline) exit_status)
-
-let run_in_ocaml =
-{
- action_name = "run-in-bytecode-toplevel";
- action_environment = env_id;
- action_body = run_test_program_in_toplevel ocaml;
-}
-
-let run_in_ocamlnat =
-{
- action_name = "run-in-native-toplevel";
- action_environment = env_id;
- action_body = run_test_program_in_toplevel ocamlnat;
-}
-
-let check_ocaml_output = make_check_compiler_output
- "check-bytecode-toplevel-output" ocaml
-
-let check_ocamlnat_output = make_check_compiler_output
- "check-native-toplevel-output" ocamlnat
-
-let if_not_safe_string = {
- action_name = "if_not_safe_string";
- action_environment = env_id;
- action_body = fun _log env ->
- if Ocamltest_config.safe_string
- then Skip "safe strings enabled"
- else Pass env
-}
+ Builtin_variables.test_pass, "0";
+ Builtin_variables.test_fail, "1";
+ Builtin_variables.test_skip, "125";
+ ] env
let _ =
+ Environments.register_initializer
+ "test_exit_status_variables" initialize_test_exit_status_variables;
List.iter register
[
- compile_bytecode_with_bytecode_compiler;
- compile_bytecode_with_native_compiler;
- compile_native_with_bytecode_compiler;
- compile_native_with_native_compiler;
- execute;
+ pass;
+ skip;
+ fail;
+ cd;
+ dumpenv;
+ libunix;
+ libwin32unix;
+ windows;
+ not_windows;
+ bsd;
+ not_bsd;
+ arch32;
+ arch64;
+ has_symlink;
+ setup_build_env;
+ run;
script;
check_program_output;
- compare_bytecode_programs;
- compare_native_programs;
- check_ocamlc_dot_byte_output;
- check_ocamlc_dot_opt_output;
- check_ocamlopt_dot_byte_output;
- check_ocamlopt_dot_opt_output;
- run_in_ocaml;
- run_in_ocamlnat;
- check_ocaml_output;
- check_ocamlnat_output;
- if_not_safe_string;
]
(* Definition of a few built-in actions *)
-val compile_bytecode_with_bytecode_compiler : Actions.t
-val compile_bytecode_with_native_compiler : Actions.t
-val compile_native_with_bytecode_compiler : Actions.t
-val compile_native_with_native_compiler : Actions.t
+val pass : Actions.t
+val skip : Actions.t
+val fail : Actions.t
-val execute : Actions.t
-val expect : Actions.t
-val script : Actions.t
-val check_program_output : Actions.t
+val dumpenv : Actions.t
+
+val libunix : Actions.t
+val libwin32unix : Actions.t
+
+val windows : Actions.t
+val not_windows : Actions.t
-val compare_bytecode_programs : Actions.t
-val compare_native_programs : Actions.t
+val bsd : Actions.t
+val not_bsd : Actions.t
-val check_ocamlc_dot_byte_output : Actions.t
-val check_ocamlc_dot_opt_output : Actions.t
-val check_ocamlopt_dot_byte_output : Actions.t
-val check_ocamlopt_dot_opt_output : Actions.t
+val arch32 : Actions.t
+val arch64 : Actions.t
-val run_in_ocaml : Actions.t
+val has_symlink : Actions.t
-val run_in_ocamlnat : Actions.t
+val setup_build_env : Actions.t
-val check_ocaml_output : Actions.t
+val setup_simple_build_env : Actions.t
-val check_ocamlnat_output : Actions.t
-val if_not_safe_string : Actions.t
+val run : Actions.t
+val script : Actions.t
+
+val check_program_output : Actions.t
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
-(* *)
-(* Copyright 2016 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(* Definition of a few built-in environment modifiers *)
-
-open Environments
-open Builtin_variables
-
-let expect =
-[
- Replace (script, "bash ${OCAMLSRCDIR}/testsuite/tools/expect");
-]
-
-let principal =
-[
- Append (flags, " -principal ");
- Add (compiler_directory_suffix, ".principal");
- Add (compiler_reference_suffix, ".principal");
-]
-
-let testinglib_directory = Ocamltest_config.ocamlsrcdir ^ "/testsuite/lib"
-
-let testing =
-[
- Append (flags, (" -I " ^ testinglib_directory ^ " "));
- Append (libraries, " testing ");
-]
-
-let _ =
- register expect "expect";
- register principal "principal";
- register testing "testing"
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
-(* *)
-(* Copyright 2016 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(* Definition of a few built-in environment modifiers *)
-
-val expect : Environments.modifiers
-
-val principal : Environments.modifiers
-
-val testing : Environments.modifiers
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
-(* *)
-(* Copyright 2016 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(* Definitions of built-in tests *)
-
-open Tests
-open Builtin_actions
-
-let bytecode =
- let opt_actions =
- [
- compile_bytecode_with_native_compiler;
- check_ocamlc_dot_opt_output;
- compare_bytecode_programs
- ] in
-{
- test_name = "bytecode";
- test_run_by_default = true;
- test_actions =
- [
- compile_bytecode_with_bytecode_compiler;
- check_ocamlc_dot_byte_output;
- execute;
- check_program_output
- ] @ (if Ocamltest_config.arch<>"none" then opt_actions else [])
-}
-
-let expect = {
- test_name = "expect";
- test_run_by_default = false;
- test_actions = [expect];
-}
-
-let native = {
- test_name = "native";
- test_run_by_default = true;
- test_actions =
- [
- compile_native_with_bytecode_compiler;
- check_ocamlopt_dot_byte_output;
- execute;
- check_program_output;
- compile_native_with_native_compiler;
- check_ocamlopt_dot_opt_output;
- compare_native_programs;
- ]
-}
-
-let script = {
- test_name = "script";
- test_run_by_default = false;
- test_actions = [script];
-}
-
-let toplevel = {
- test_name = "toplevel";
- test_run_by_default = false;
- test_actions =
- [
- run_in_ocaml;
- check_ocaml_output;
-(*
- run_in_ocamlnat;
- check_ocamlnat_output;
-*)
- ]
-}
-
-let _ =
- List.iter register
- [
- bytecode;
- expect;
- script;
- toplevel;
- ];
- if (Ocamltest_config.arch <> "none") then register native
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
-(* *)
-(* Copyright 2016 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(* Definitions of built-in tests *)
-
-val bytecode : Tests.t
-
-val expect : Tests.t
-
-val native : Tests.t
-
-val script : Tests.t
-
-val toplevel : Tests.t
let arguments = make ("arguments",
"Arguments passed to executed programs and scripts")
-let c_preprocessor = make ("c_preprocessor",
- "Command to use to invoke the C preprocessor")
+let cwd = make ("cwd",
+ "Used to change current working directory, but not updated")
-let compiler_directory_suffix = make ("compiler_directory_suffix",
- "Suffix to add to the directory where the test will be compiled")
-
-let compiler_reference = make ("compiler_reference",
- "Reference file for compiler output for ocamlc.byte and ocamlopt.byte")
-
-let compiler_reference2 = make ("compiler_reference2",
- "Reference file for compiler output for ocamlc.opt and ocamlopt.opt")
-
-let compiler_reference_suffix = make ("compiler_reference_suffix",
- "Suffix to add to the file name containing the reference for compiler output")
-
-let compiler_output = make ("compiler_output",
- "Where to log output of bytecode compilers")
-
-let compiler_output2 = make ("compiler_output2",
- "Where to log output of native compilers")
-
-let ocamlc_flags = make ("ocamlc_flags",
- "Flags passed to ocamlc.byte and ocamlc.opt")
-
-let ocamlc_default_flags = make ("ocamlc_default_flags",
- "Flags passed by default to ocamlc.byte and ocamlc.opt")
+let exit_status = make ("exit_status",
+ "Expected program exit status")
let files = make ("files",
"Files used by the tests")
-let flags = make ("flags",
- "Flags passed to all the compilers")
-
-let libraries = make ("libraries",
- "Libraries the program should be linked with")
-
-let modules = make ("modules",
- "Other modules of the test")
-
-let ocamlopt_flags = make ("ocamlopt_flags",
- "Flags passed to ocamlopt.byte and ocamlopt.opt")
-
-let ocamlopt_default_flags = make ("ocamlopt_default_flags",
- "Flags passed by default to ocamlopt.byte and ocamlopt.opt")
-
-let ocaml_byte_exit_status = make ("ocaml_byte_exit_status",
- "Expected exit status of ocaml.byte")
-
-let ocamlc_byte_exit_status = make ("ocamlc_byte_exit_status",
- "Expected exit status of ocac.byte")
+let ocamltest_response = make ("ocamltest_response",
+ "File used by hooks to send back information.")
-let ocamlopt_byte_exit_status = make ("ocamlopt_byte_exit_status",
- "Expected exit status of ocamlopt.byte")
-
-let ocaml_opt_exit_status = make ("ocaml_opt_exit_status",
- "Expected exit status of ocaml.opt")
-
-let ocamlc_opt_exit_status = make ("ocamlc_opt_exit_status",
- "Expected exit status of ocac.opt")
-
-let ocamlopt_opt_exit_status = make ("ocamlopt_opt_exit_status",
- "Expected exit status of ocamlopt.opt")
+let ocamltest_log = make ("ocamltest_log",
+ "Path to log file for the current test")
let output = make ("output",
"Where the output of executing the program is saved")
let program2 = make ("program2",
"Name of program produced by ocamlc.opt and ocamlopt.opt")
+let promote = make ("promote",
+ "Set to \"true\" to overwrite reference files with the test output")
+
+let reason = make ("reason",
+ "Let a test report why it passed/skipped/failed.")
+
let reference = make ("reference",
"Path of file to which program output should be compared")
+let skip_header_lines =
+ make ( "skip_header_lines",
+ "The number of lines to skip when comparing program output \
+ with the reference file")
+
+let skip_header_bytes =
+ make ( "skip_header_bytes",
+ "The number of bytes to skip when comparing program output \
+ with the reference file")
+
let script = make ("script",
"External script to run")
let test_build_directory = make ("test_build_directory",
"Directory for files produced during a test")
+let test_build_directory_prefix = make ("test_build_directory_prefix",
+ "Directory under which all test directories should be created")
+
let test_file = make ("test_file",
"Name of file containing the specification of which tests to run")
let test_source_directory = make ("test_source_directory",
"Directory containing the test source files")
+let test_pass = make ("TEST_PASS",
+ "Exit code to let a script report success")
+
+let test_skip = make ("TEST_SKIP",
+ "Exit code to let a script report skipping")
+
+let test_fail = make ("TEST_FAIL",
+ "Exit code to let a script report failure")
+
+
+
let _ = List.iter register_variable
[
- c_preprocessor;
- ocamlc_default_flags;
- ocamlopt_default_flags
+ arguments;
+ cwd;
+ exit_status;
+ files;
+ ocamltest_response;
+ ocamltest_log;
+ output;
+ program; program2;
+ reason;
+ reference;
+ skip_header_lines;
+ skip_header_bytes;
+ script;
+ stdin;
+ stdout;
+ stderr;
+ test_build_directory;
+ test_file;
+ test_source_directory;
+ test_pass;
+ test_skip;
+ test_fail;
]
val arguments : Variables.t
-val c_preprocessor : Variables.t
+val cwd : Variables.t
-val compiler_directory_suffix : Variables.t
-
-val compiler_reference : Variables.t
-
-val compiler_reference2 : Variables.t
-
-val compiler_reference_suffix : Variables.t
-
-val compiler_output : Variables.t
-
-val compiler_output2 : Variables.t
+val exit_status : Variables.t
val files : Variables.t
-val flags : Variables.t
-
-val libraries : Variables.t
-
-val modules : Variables.t
-
-val ocamlc_flags : Variables.t
-val ocamlc_default_flags : Variables.t
-
-val ocamlopt_flags : Variables.t
-val ocamlopt_default_flags : Variables.t
-
-val ocaml_byte_exit_status : Variables.t
+val ocamltest_response : Variables.t
-val ocamlc_byte_exit_status : Variables.t
-
-val ocamlopt_byte_exit_status : Variables.t
-
-val ocaml_opt_exit_status : Variables.t
-
-val ocamlc_opt_exit_status : Variables.t
-
-val ocamlopt_opt_exit_status : Variables.t
+val ocamltest_log : Variables.t
val output : Variables.t
val program : Variables.t
val program2 : Variables.t
+val promote : Variables.t
+
+val reason : Variables.t
+
val reference : Variables.t
+val skip_header_lines : Variables.t
+val skip_header_bytes : Variables.t
+
val script : Variables.t
val stdin : Variables.t
val stderr : Variables.t
val test_build_directory : Variables.t
+val test_build_directory_prefix : Variables.t
val test_file : Variables.t
val test_source_directory : Variables.t
+
+val test_pass : Variables.t
+
+val test_skip : Variables.t
+
+val test_fail : Variables.t
(* Definition of environments, used to pass parameters to tests and actions *)
-exception Variable_already_defined of Variables.t
+open Ocamltest_stdlib
module VariableMap = Map.Make (Variables)
let f variable value lst = (variable, value) :: lst in
VariableMap.fold f env []
-let expand env value =
-
+let expand_aux env value =
let bindings = to_bindings env in
let f (variable, value) = ((Variables.name_of_variable variable), value) in
let simple_bindings = List.map f bindings in
let b = Buffer.create 100 in
try Buffer.add_substitute b subst value; Buffer.contents b with _ -> value
+let rec expand env value =
+ let expanded = expand_aux env value in
+ if expanded=value then value else expand env expanded
+
+let to_system_env env =
+ let system_env = Array.make (VariableMap.cardinal env) "" in
+ let i = ref 0 in
+ let store variable value =
+ system_env.(!i) <-
+ Variables.string_of_binding variable (expand env value);
+ incr i in
+ VariableMap.iter store env;
+ system_env
+
let lookup variable env =
try Some (expand env (VariableMap.find variable env)) with Not_found -> None
+let lookup_nonempty variable env = match lookup variable env with
+ | None -> None
+ | Some x as t -> if String.words x = [] then None else t
+
+let lookup_as_bool variable env =
+ match lookup variable env with
+ | None -> None
+ | Some "true" -> Some true
+ | Some _ -> Some false
+
let safe_lookup variable env = match lookup variable env with
| None -> ""
| Some value -> value
let is_variable_defined variable env =
VariableMap.mem variable env
-let add variable value env =
- if VariableMap.mem variable env
- then raise (Variable_already_defined variable)
- else VariableMap.add variable value env
+let add variable value env = VariableMap.add variable value env
-let replace variable value environment =
- VariableMap.add variable value environment
+let add_if_undefined variable value env =
+ if VariableMap.mem variable env then env else add variable value env
let append variable appened_value environment =
let previous_value = safe_lookup variable environment in
let new_value = previous_value ^ appened_value in
VariableMap.add variable new_value environment
+let remove = VariableMap.remove
+
let add_bindings bindings env =
let f env (variable, value) = add variable value env in
List.fold_left f env bindings
Printf.fprintf log "%s = %s\n%!" (Variables.name_of_variable variable) value
let dump log environment =
- List.iter (dump_assignment log) (VariableMap.bindings environment);
+ List.iter (dump_assignment log) (VariableMap.bindings environment)
+
+(* Initializers *)
-(* Environment modifiers *)
+type env_initializer = out_channel -> t -> t
+
+let (initializers : (string, env_initializer) Hashtbl.t) = Hashtbl.create 10
+
+let register_initializer name code = Hashtbl.add initializers name code
+
+let apply_initializer _log _name code env =
+ code _log env
+
+let initialize log env =
+ let f = apply_initializer log in
+ Hashtbl.fold f initializers env
+
+(* Modifiers *)
type modifier =
| Include of string
| Add of Variables.t * string
- | Replace of Variables.t * string
| Append of Variables.t * string
+ | Remove of Variables.t
type modifiers = modifier list
let (registered_modifiers : (string, modifiers) Hashtbl.t) = Hashtbl.create 20
-let register modifiers name =
+let register_modifiers name modifiers =
if name="" then raise Empty_modifiers_name
else if Hashtbl.mem registered_modifiers name
then raise (Modifiers_name_already_registered name)
| Include modifiers_name ->
apply_modifiers environment (find_modifiers modifiers_name)
| Add (variable, value) -> add variable value environment
- | Replace (variable, value) -> replace variable value environment
| Append (variable, value) -> append variable value environment
+ | Remove variable -> remove variable environment
and apply_modifiers environment modifiers =
List.fold_left apply_modifier environment modifiers
+
+let modifier_of_string str =
+ let invalid_argument = (Invalid_argument "modifier_of_string") in
+ if str="" then raise invalid_argument else begin
+ let l = String.length str in
+ if str.[0] = '-' then begin
+ let variable_name = String.sub str 1 (l-1) in
+ match Variables.find_variable variable_name with
+ | None -> raise (Variables.No_such_variable variable_name)
+ | Some variable -> Remove variable
+ end else begin match String.index_opt str '=' with
+ | None -> raise invalid_argument
+ | Some pos_eq -> if pos_eq <= 0 then raise invalid_argument else
+ let (append, varname_length) =
+ (match String.index_opt str '+' with
+ | None -> (false, pos_eq)
+ | Some pos_plus ->
+ if pos_plus = pos_eq-1
+ then (true, pos_plus)
+ else raise invalid_argument) in
+ let variable_name = String.sub str 0 varname_length in
+ match Variables.find_variable variable_name with
+ | None -> raise (Variables.No_such_variable variable_name)
+ | Some variable ->
+ if pos_eq >= l-2 || str.[pos_eq+1]<>'"' || str.[l-1]<>'"'
+ then raise invalid_argument
+ else let value_length = l - pos_eq - 3 in
+ let value = String.sub str (pos_eq+2) value_length in
+ if append then Append (variable, value)
+ else Add (variable, value)
+ end
+ end
+
+let modifiers_of_file filename =
+ let ic = open_in filename in
+ let rec modifiers_of_lines acc = match input_line_opt ic with
+ | None -> acc
+ | Some line ->
+ modifiers_of_lines ((modifier_of_string (String.trim line)) :: acc) in
+ let modifiers = modifiers_of_lines [] in
+ close_in ic;
+ List.rev modifiers
(* Definition of environments, used to pass parameters to tests and actions *)
-exception Variable_already_defined of Variables.t
-
type t
val empty : t
val from_bindings : (Variables.t * string) list -> t
val to_bindings : t -> (Variables.t * string) list
+val to_system_env : t -> string array
val lookup : Variables.t -> t -> string option
+val lookup_nonempty : Variables.t -> t -> string option
val safe_lookup : Variables.t -> t -> string
val is_variable_defined : Variables.t -> t -> bool
+val lookup_as_bool : Variables.t -> t -> bool option
+(** returns [Some true] if the variable is set to ["true"],
+ [Some false] if it is set to another string, and
+ [None] if not set. *)
+
val add : Variables.t -> string -> t -> t
+val add_if_undefined : Variables.t -> string -> t -> t
val add_bindings : (Variables.t * string) list -> t -> t
+val append : Variables.t -> string -> t -> t
+
val dump : out_channel -> t -> unit
-(* Environment modifiers *)
+(* Initializers *)
+
+type env_initializer = out_channel -> t -> t
+
+val register_initializer : string -> env_initializer -> unit
+
+val initialize : env_initializer
+
+(* Modifiers *)
type modifier =
| Include of string
| Add of Variables.t * string
- | Replace of Variables.t * string
| Append of Variables.t * string
+ | Remove of Variables.t
type modifiers = modifier list
exception Modifiers_name_already_registered of string
exception Modifiers_name_not_found of string
-val register : modifiers -> string -> unit
+val register_modifiers : string -> modifiers -> unit
+
+val modifier_of_string : string -> modifier
+
+val modifiers_of_file : string -> modifiers
(* File comparison tools *)
+open Ocamltest_stdlib
+
type result =
| Same
| Different
| Unexpected_output
| Error of string * int
+type ignore = {bytes: int; lines: int}
type tool =
| External of {
tool_name : string;
tool_flags : string;
result_of_exitcode : string -> int -> result
}
- | Internal of int
+ | Internal of ignore
let cmp_result_of_exitcode commandline = function
| 0 -> Same
| 1 -> Different
| exit_code -> (Error (commandline, exit_code))
-let make_cmp_tool bytes_to_ignore =
- Internal bytes_to_ignore
+let make_cmp_tool ~ignore =
+ Internal ignore
let make_comparison_tool ?(result_of_exitcode = cmp_result_of_exitcode)
name flags =
result_of_exitcode
}
-let default_comparison_tool = make_cmp_tool 0
+let default_comparison_tool = make_cmp_tool ~ignore:{bytes=0;lines=0}
type filetype = Binary | Text
output_filename : string;
}
-let read_text_file fn =
+let read_text_file lines_to_drop fn =
let ic = open_in_bin fn in
let drop_cr s =
let l = String.length s in
if l > 0 && s.[l - 1] = '\r' then String.sub s 0 (l - 1)
else raise Exit
in
- let rec loop acc =
+ let rec drop k =
+ if k = 0 then
+ loop []
+ else
+ let stop = try ignore (input_line ic); false with End_of_file -> true in
+ if stop then [] else drop (k-1)
+ and loop acc =
match input_line ic with
| s -> loop (s :: acc)
| exception End_of_file ->
try List.rev_map drop_cr acc
with Exit -> List.rev acc
in
- loop []
+ drop lines_to_drop
-let compare_text_files file1 file2 =
- if read_text_file file1 = read_text_file file2 then
+let compare_text_files dropped_lines file1 file2 =
+ if read_text_file 0 file1 = read_text_file dropped_lines file2 then
Same
else
Different
~stdout_fname:dev_null ~stderr_fname:dev_null commandline in
let status = Run_command.run settings in
result_of_exitcode commandline status
- | Internal bytes_to_ignore ->
+ | Internal ignore ->
match files.filetype with
| Text ->
(* bytes_to_ignore is silently ignored for text files *)
- compare_text_files files.reference_filename files.output_filename
+ compare_text_files ignore.lines
+ files.reference_filename files.output_filename
| Binary ->
- compare_binary_files bytes_to_ignore
+ compare_binary_files ignore.bytes
files.reference_filename files.output_filename
let check_file ?(tool = default_comparison_tool) files =
if Sys.file_exists files.reference_filename
then compare_files ~tool:tool files
else begin
- if Testlib.file_is_empty files.output_filename
+ if Sys.file_is_empty files.output_filename
then Same
else Unexpected_output
end
"> " ^ temporary_file
] in
if (Sys.command diff_commandline) = 2 then Pervasives.Error "diff"
- else Ok (Testlib.string_of_file temporary_file)
+ else Ok (Sys.string_of_file temporary_file)
type tool
-val make_cmp_tool : int -> tool
+type ignore = {bytes: int; lines: int}
+val make_cmp_tool : ignore:ignore -> tool
val make_comparison_tool :
?result_of_exitcode:(string -> int -> result) -> string -> string -> tool
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
-(* *)
-(* Copyright 2016 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(* Types of input files involved in an OCaml project and related functions *)
-
-type t =
- | Implementation
- | Interface
- | C
- | C_minus_minus
- | Lexer
- | Grammar
-
-let string_of_filetype = function
- | Implementation -> "implementation"
- | Interface -> "interface"
- | C -> "C source file"
- | C_minus_minus -> "C minus minus source file"
- | Lexer -> "lexer"
- | Grammar -> "grammar"
-
-let extension_of_filetype = function
- | Implementation -> "ml"
- | Interface -> "mli"
- | C -> "c"
- | C_minus_minus -> "cmm"
- | Lexer -> "mll"
- | Grammar -> "mly"
-
-let filetype_of_extension = function
- | "ml" -> Implementation
- | "mli" -> Interface
- | "c" -> C
- | "cmm" -> C_minus_minus
- | "mll" -> Lexer
- | "mly" -> Grammar
- | _ -> raise Not_found
-
-let split_filename name =
- let l = String.length name in
- let is_dir_sep name i = name.[i] = Filename.dir_sep.[0] in
- let rec search_dot i =
- if i < 0 || is_dir_sep name i then (name, "")
- else if name.[i] = '.' then
- let basename = String.sub name 0 i in
- let extension = String.sub name (i+1) (l-i-1) in
- (basename, extension)
- else search_dot (i - 1) in
- search_dot (l - 1)
-
-let filetype filename =
- let (basename, extension) = split_filename filename in
- (basename, filetype_of_extension extension)
-
-let make_filename (basename, filetype) =
- let extension = extension_of_filetype filetype in
- basename ^ "." ^ extension
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
-(* *)
-(* Copyright 2016 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(* Types of input files involved in an OCaml project and related functions *)
-
-type t =
- | Implementation
- | Interface
- | C
- | C_minus_minus
- | Lexer
- | Grammar
-
-val string_of_filetype : t -> string
-
-val extension_of_filetype : t -> string
-
-val filetype_of_extension : string -> t
-
-val split_filename : string -> string * string
-
-val filetype : string -> string * t
-
-val make_filename : string * t -> string
(* Main program of the ocamltest test driver *)
+open Ocamltest_stdlib
open Tsl_semantics
+type behavior =
+ | Skip_all_tests
+ | Run of Environments.t
+
(*
let first_token filename =
let input_channel = open_in filename in
let is_test filename =
match first_token filename with
| exception _ -> false
- | Tsl_parser.TSL_BEGIN -> true
+ | Tsl_parser.TSL_BEGIN_C_STYLE | TSL_BEGIN_OCAML_STYLE -> true
| _ -> false
*)
+(* this primitive announce should be used for tests
+ that were aborted on system error before ocamltest
+ could parse them *)
+let announce_test_error test_filename error =
+ Printf.printf " ... testing '%s' => unexpected error (%s)\n%!"
+ (Filename.basename test_filename) error
+
let tsl_block_of_file test_filename =
let input_channel = open_in test_filename in
let lexbuf = Lexing.from_channel input_channel in
let tsl_block_of_file_safe test_filename =
try tsl_block_of_file test_filename with
| Sys_error message ->
- Printf.eprintf "%s\n" message;
+ Printf.eprintf "%s\n%!" message;
+ announce_test_error test_filename message;
exit 1
| Parsing.Parse_error ->
- Printf.eprintf "Could not read test block in %s\n" test_filename;
+ Printf.eprintf "Could not read test block in %s\n%!" test_filename;
+ announce_test_error test_filename "could not read test block";
exit 1
let print_usage () =
Printf.printf "%s\n%!" Options.usage
-let rec run_test log common_prefix path ancestor_result = function
+let rec run_test log common_prefix path behavior = function
Node (testenvspec, test, env_modifiers, subtrees) ->
Printf.printf "%s %s (%s) => %!" common_prefix path test.Tests.test_name;
- let print_test_result str = Printf.printf "%s\n%!" str in
- let test_result = match ancestor_result with
- | Actions.Pass env -> (* Ancestor succeded, really run the test *)
+ let (msg, b) = match behavior with
+ | Skip_all_tests -> "skipped", Skip_all_tests
+ | Run env ->
let testenv0 = interprete_environment_statements env testenvspec in
let testenv = List.fold_left apply_modifiers testenv0 env_modifiers in
- Tests.run log testenv test
- | Actions.Skip _ -> (Actions.Skip "ancestor test skipped")
- | Actions.Fail _ -> (Actions.Skip "ancestor test failed") in
- let result_to_pass = match test_result with
- | Actions.Pass _ ->
- print_test_result "passed";
- test_result
- | Actions.Fail _ ->
- print_test_result "failed";
- ancestor_result
- | Actions.Skip _ ->
- print_test_result "skipped";
- ancestor_result in
- List.iteri (run_test_i log common_prefix path result_to_pass) subtrees
-and run_test_i log common_prefix path ancestor_result i test_tree =
+ let (result, newenv) = Tests.run log testenv test in
+ let s = Result.string_of_result result in
+ if Result.is_pass result then (s, Run newenv)
+ else (s, Skip_all_tests) in
+ Printf.printf "%s\n%!" msg;
+ List.iteri (run_test_i log common_prefix path b) subtrees
+and run_test_i log common_prefix path behavior i test_tree =
let path_prefix = if path="" then "" else path ^ "." in
let new_path = Printf.sprintf "%s%d" path_prefix (i+1) in
- run_test log common_prefix new_path ancestor_result test_tree
+ run_test log common_prefix new_path behavior test_tree
let get_test_source_directory test_dirname =
- if not (Filename.is_relative test_dirname) then test_dirname
- else let pwd = Sys.getcwd() in
- Filename.concat pwd test_dirname
+ if (Filename.is_relative test_dirname) then
+ Sys.with_chdir test_dirname Sys.getcwd
+ else test_dirname
-let get_test_build_directory test_dirname =
+let get_test_build_directory_prefix test_dirname =
let ocamltestdir_variable = "OCAMLTESTDIR" in
- let root = try Sys.getenv ocamltestdir_variable with
- | Not_found -> (Filename.concat (Sys.getcwd ()) "_ocamltest") in
+ let root =
+ Sys.getenv_with_default_value ocamltestdir_variable
+ (Filename.concat (Sys.getcwd ()) "_ocamltest")
+ in
if test_dirname = "." then root
else Filename.concat root test_dirname
-let main () =
- if !Options.testfile = "" then begin
- print_usage();
- exit 1
- end;
- let test_filename = !Options.testfile in
+let test_file test_filename =
(* Printf.printf "# reading test file %s\n%!" test_filename; *)
+ (* Save current working directory *)
+ let cwd = Sys.getcwd() in
let tsl_block = tsl_block_of_file_safe test_filename in
let (rootenv_statements, test_trees) = test_trees_of_tsl_block tsl_block in
let test_trees = match test_trees with
let make_tree test = Node ([], test, [], []) in
List.map make_tree default_tests
| _ -> test_trees in
- let actions = actions_in_tests (tests_in_trees test_trees) in
+ let used_tests = tests_in_trees test_trees in
+ let used_actions = actions_in_tests used_tests in
+ let action_names =
+ let f act names = StringSet.add (Actions.action_name act) names in
+ Actions.ActionSet.fold f used_actions StringSet.empty in
let test_dirname = Filename.dirname test_filename in
let test_basename = Filename.basename test_filename in
let test_prefix = Filename.chop_extension test_basename in
if test_dirname="." then test_prefix
else Filename.concat test_dirname test_prefix in
let test_source_directory = get_test_source_directory test_dirname in
- let test_build_directory = get_test_build_directory test_directory in
- let reference_filename = Filename.concat
- test_source_directory (test_prefix ^ ".reference") in
- let initial_environment = Environments.from_bindings
- [
- Builtin_variables.c_preprocessor, Ocamltest_config.c_preprocessor;
- Builtin_variables.ocamlc_default_flags,
- Ocamltest_config.ocamlc_default_flags;
- Builtin_variables.ocamlopt_default_flags,
- Ocamltest_config.ocamlopt_default_flags;
- Builtin_variables.test_file, test_basename;
- Builtin_variables.reference, reference_filename;
- Builtin_variables.test_source_directory, test_source_directory;
- Builtin_variables.test_build_directory, test_build_directory;
- ] in
- let root_environment =
- interprete_environment_statements initial_environment rootenv_statements in
- let rootenv = Actions.update_environment root_environment actions in
- Testlib.make_directory test_build_directory;
- Sys.chdir test_build_directory;
- let log_filename = test_prefix ^ ".log" in
- let log = open_out log_filename in
- let common_prefix = " ... testing '" ^ test_basename ^ "' with" in
- List.iteri
- (run_test_i log common_prefix "" (Actions.Pass rootenv))
- test_trees;
- close_out log
+ let hookname_prefix = Filename.concat test_source_directory test_prefix in
+ let test_build_directory_prefix =
+ get_test_build_directory_prefix test_directory in
+ ignore (Sys.command ("rm -rf " ^ test_build_directory_prefix));
+ Sys.make_directory test_build_directory_prefix;
+ Sys.with_chdir test_build_directory_prefix
+ (fun () ->
+ let log =
+ if !Options.log_to_stderr then stderr else begin
+ let log_filename = test_prefix ^ ".log" in
+ open_out log_filename
+ end in
+ let promote = string_of_bool !Options.promote in
+ let install_hook name =
+ let hook_name = Filename.make_filename hookname_prefix name in
+ if Sys.file_exists hook_name then begin
+ let hook = Actions_helpers.run_hook hook_name in
+ Actions.set_hook name hook
+ end in
+ StringSet.iter install_hook action_names;
+
+ let reference_filename = Filename.concat
+ test_source_directory (test_prefix ^ ".reference") in
+ let initial_environment = Environments.from_bindings
+ [
+ Builtin_variables.test_file, test_basename;
+ Builtin_variables.reference, reference_filename;
+ Builtin_variables.test_source_directory, test_source_directory;
+ Builtin_variables.test_build_directory_prefix,
+ test_build_directory_prefix;
+ Builtin_variables.promote, promote;
+ ] in
+ let root_environment =
+ interprete_environment_statements
+ initial_environment rootenv_statements in
+ let rootenv = Environments.initialize log root_environment in
+ let common_prefix = " ... testing '" ^ test_basename ^ "' with" in
+ List.iteri
+ (run_test_i log common_prefix "" (Run rootenv))
+ test_trees;
+ Actions.clear_all_hooks();
+ if not !Options.log_to_stderr then close_out log
+ );
+ (* Restore current working directory *)
+ Sys.chdir cwd
+
+let main () =
+ if !Options.files_to_test = [] then begin
+ print_usage();
+ exit 1
+ end;
+ List.iter test_file !Options.files_to_test
let _ = main()
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2017 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Actions specific to the OCaml compilers *)
+
+open Ocamltest_stdlib
+open Actions
+
+(* Extracting information from environment *)
+
+let native_support = Ocamltest_config.arch <> "none"
+
+let no_native_compilers _log env =
+ (Result.skip_with_reason "native compilers disabled", env)
+
+let native_action a =
+ if native_support then a else (Actions.update a no_native_compilers)
+
+let get_backend_value_from_env env bytecode_var native_var =
+ Ocaml_backends.make_backend_function
+ (Environments.safe_lookup bytecode_var env)
+ (Environments.safe_lookup native_var env)
+
+let modules env =
+ Actions_helpers.words_of_variable env Ocaml_variables.modules
+
+let plugins env =
+ Actions_helpers.words_of_variable env Ocaml_variables.plugins
+
+let directories env =
+ Actions_helpers.words_of_variable env Ocaml_variables.directories
+
+let directory_flags env =
+ let f dir = ("-I " ^ dir) in
+ let l = List.map f (directories env) in
+ String.concat " " l
+
+let flags env = Environments.safe_lookup Ocaml_variables.flags env
+
+let ocamllex_flags env =
+ Environments.safe_lookup Ocaml_variables.ocamllex_flags env
+
+let ocamlyacc_flags env =
+ Environments.safe_lookup Ocaml_variables.ocamlyacc_flags env
+
+let filelist env variable extension =
+ let value = Environments.safe_lookup variable env in
+ let filenames = String.words value in
+ let add_extension filename = Filename.make_filename filename extension in
+ String.concat " " (List.map add_extension filenames)
+
+let libraries backend env =
+ let extension = Ocaml_backends.library_extension backend in
+ filelist env Ocaml_variables.libraries extension
+
+let binary_modules backend env =
+ let extension = Ocaml_backends.module_extension backend in
+ filelist env Ocaml_variables.binary_modules extension
+
+let backend_default_flags env =
+ get_backend_value_from_env env
+ Ocaml_variables.ocamlc_default_flags
+ Ocaml_variables.ocamlopt_default_flags
+
+let backend_flags env =
+ get_backend_value_from_env env
+ Ocaml_variables.ocamlc_flags
+ Ocaml_variables.ocamlopt_flags
+
+let dumb_term = [|"TERM=dumb"|]
+
+type module_generator = {
+ description : string;
+ command : string -> string;
+ flags : Environments.t -> string;
+ generated_compilation_units :
+ string -> (string * Ocaml_filetypes.t) list
+}
+
+let ocamllex =
+{
+ description = "lexer";
+ command = Ocaml_commands.ocamlrun_ocamllex;
+ flags = ocamllex_flags;
+ generated_compilation_units =
+ fun lexer_name -> [(lexer_name, Ocaml_filetypes.Implementation)]
+}
+
+let ocamlyacc =
+{
+ description = "parser";
+ command = Ocaml_files.ocamlyacc;
+ flags = ocamlyacc_flags;
+ generated_compilation_units =
+ fun parser_name ->
+ [
+ (parser_name, Ocaml_filetypes.Interface);
+ (parser_name, Ocaml_filetypes.Implementation)
+ ]
+}
+
+let generate_module generator ocamlsrcdir output_variable input log env =
+ let basename = fst input in
+ let input_file = Ocaml_filetypes.make_filename input in
+ let what =
+ Printf.sprintf "Generating %s module from %s"
+ generator.description input_file
+ in
+ Printf.fprintf log "%s\n%!" what;
+ let commandline =
+ [
+ generator.command ocamlsrcdir;
+ generator.flags env;
+ input_file
+ ] in
+ let expected_exit_status = 0 in
+ let exit_status =
+ Actions_helpers.run_cmd
+ ~environment:dumb_term
+ ~stdin_variable: Ocaml_variables.compiler_stdin
+ ~stdout_variable:output_variable
+ ~stderr_variable:output_variable
+ ~append:true
+ log env commandline in
+ if exit_status=expected_exit_status
+ then generator.generated_compilation_units basename
+ else begin
+ let reason =
+ (Actions_helpers.mkreason
+ what (String.concat " " commandline) exit_status) in
+ Printf.fprintf log "%s\n%!" reason;
+ []
+ end
+
+let generate_lexer = generate_module ocamllex
+
+let generate_parser = generate_module ocamlyacc
+
+let prepare_module ocamlsrcdir output_variable log env input =
+ let input_type = snd input in
+ let open Ocaml_filetypes in
+ match input_type with
+ | Implementation | Interface | C -> [input]
+ | Binary_interface -> [input]
+ | Backend_specific _ -> [input]
+ | C_minus_minus -> assert false
+ | Lexer ->
+ generate_lexer ocamlsrcdir output_variable input log env
+ | Grammar ->
+ generate_parser ocamlsrcdir output_variable input log env
+ | Text -> assert false
+
+let get_program_file backend env =
+ let testfile = Actions_helpers.testfile env in
+ let testfile_basename = Filename.chop_extension testfile in
+ let program_filename =
+ Filename.mkexe
+ (Filename.make_filename
+ testfile_basename (Ocaml_backends.executable_extension backend)) in
+ let test_build_directory =
+ Actions_helpers.test_build_directory env in
+ Filename.make_path [test_build_directory; program_filename]
+
+let compile_program ocamlsrcdir (compiler : Ocaml_compilers.compiler) log env =
+ let program_variable = compiler#program_variable in
+ let program_file = Environments.safe_lookup program_variable env in
+ let all_modules =
+ Actions_helpers.words_of_variable env Ocaml_variables.all_modules in
+ let output_variable = compiler#output_variable in
+ let prepare = prepare_module ocamlsrcdir output_variable log env in
+ let modules =
+ List.concatmap prepare (List.map Ocaml_filetypes.filetype all_modules) in
+ let is_c_file (_filename, filetype) = filetype=Ocaml_filetypes.C in
+ let has_c_file = List.exists is_c_file modules in
+ let c_headers_flags =
+ if has_c_file then Ocaml_flags.c_includes ocamlsrcdir else "" in
+ let expected_exit_status =
+ Ocaml_tools.expected_exit_status env (compiler :> Ocaml_tools.tool) in
+ let module_names =
+ (binary_modules compiler#target env) ^ " " ^
+ (String.concat " " (List.map Ocaml_filetypes.make_filename modules)) in
+ let what = Printf.sprintf "Compiling program %s from modules %s"
+ program_file module_names in
+ Printf.fprintf log "%s\n%!" what;
+ let compile_only =
+ Environments.lookup_as_bool Ocaml_variables.compile_only env = Some true
+ in
+ let compile_flags =
+ if compile_only then " -c " else ""
+ in
+ let output = if compile_only then "" else "-o " ^ program_file in
+ let commandline =
+ [
+ compiler#name ocamlsrcdir;
+ Ocaml_flags.runtime_flags ocamlsrcdir compiler#target has_c_file;
+ c_headers_flags;
+ Ocaml_flags.stdlib ocamlsrcdir;
+ directory_flags env;
+ flags env;
+ libraries compiler#target env;
+ backend_default_flags env compiler#target;
+ backend_flags env compiler#target;
+ compile_flags;
+ output;
+ module_names
+ ] in
+ let exit_status =
+ Actions_helpers.run_cmd
+ ~environment:dumb_term
+ ~stdin_variable: Ocaml_variables.compiler_stdin
+ ~stdout_variable:compiler#output_variable
+ ~stderr_variable:compiler#output_variable
+ ~append:true
+ log env commandline in
+ if exit_status=expected_exit_status
+ then (Result.pass, env)
+ else begin
+ let reason =
+ (Actions_helpers.mkreason
+ what (String.concat " " commandline) exit_status) in
+ (Result.fail_with_reason reason, env)
+ end
+
+let compile_module ocamlsrcdir compiler module_ log env =
+ let expected_exit_status =
+ Ocaml_tools.expected_exit_status env (compiler :> Ocaml_tools.tool) in
+ let what = Printf.sprintf "Compiling module %s" module_ in
+ Printf.fprintf log "%s\n%!" what;
+ let commandline =
+ [
+ compiler#name ocamlsrcdir;
+ Ocaml_flags.stdlib ocamlsrcdir;
+ directory_flags env;
+ flags env;
+ libraries compiler#target env;
+ backend_default_flags env compiler#target;
+ backend_flags env compiler#target;
+ "-c " ^ module_;
+ ] in
+ let exit_status =
+ Actions_helpers.run_cmd
+ ~environment:dumb_term
+ ~stdin_variable: Ocaml_variables.compiler_stdin
+ ~stdout_variable:compiler#output_variable
+ ~stderr_variable:compiler#output_variable
+ ~append:true
+ log env commandline in
+ if exit_status=expected_exit_status
+ then (Result.pass, env)
+ else begin
+ let reason =
+ (Actions_helpers.mkreason
+ what (String.concat " " commandline) exit_status) in
+ (Result.fail_with_reason reason, env)
+ end
+
+let module_has_interface directory module_name =
+ let interface_name =
+ Ocaml_filetypes.make_filename (module_name, Ocaml_filetypes.Interface) in
+ let interface_fullpath = Filename.make_path [directory;interface_name] in
+ Sys.file_exists interface_fullpath
+
+let add_module_interface directory module_description =
+ match module_description with
+ | (filename, Ocaml_filetypes.Implementation) when
+ module_has_interface directory filename ->
+ [(filename, Ocaml_filetypes.Interface); module_description]
+ | _ -> [module_description]
+
+let print_module_names log description modules =
+ Printf.fprintf log "%s modules: %s\n%!"
+ description
+ (String.concat " " (List.map Ocaml_filetypes.make_filename modules))
+
+let find_source_modules log env =
+ let source_directory = Actions_helpers.test_source_directory env in
+ let specified_modules =
+ List.map Ocaml_filetypes.filetype
+ ((plugins env) @ (modules env) @ [(Actions_helpers.testfile env)]) in
+ print_module_names log "Specified" specified_modules;
+ let source_modules =
+ List.concatmap
+ (add_module_interface source_directory)
+ specified_modules in
+ print_module_names log "Source" source_modules;
+ Environments.add
+ Ocaml_variables.all_modules
+ (String.concat " " (List.map Ocaml_filetypes.make_filename source_modules))
+ env
+
+let setup_tool_build_env tool log env =
+ let source_directory = Actions_helpers.test_source_directory env in
+ let testfile = Actions_helpers.testfile env in
+ let testfile_basename = Filename.chop_extension testfile in
+ let tool_reference_variable =
+ tool#reference_variable in
+ let tool_reference_prefix =
+ Filename.make_path [source_directory; testfile_basename] in
+ let tool_reference_file =
+ tool#reference_file env tool_reference_prefix
+ in
+ let env =
+ Environments.add_if_undefined
+ tool_reference_variable
+ tool_reference_file env
+ in
+ let source_modules =
+ Actions_helpers.words_of_variable env Ocaml_variables.all_modules in
+ let tool_directory_suffix =
+ Environments.safe_lookup Ocaml_variables.compiler_directory_suffix env in
+ let tool_directory_name =
+ tool#directory ^ tool_directory_suffix in
+ let build_dir = Filename.concat
+ (Environments.safe_lookup
+ Builtin_variables.test_build_directory_prefix env)
+ tool_directory_name in
+ let tool_output_variable = tool#output_variable in
+ let tool_output_filename =
+ Filename.make_filename tool#directory "output" in
+ let tool_output_file =
+ Filename.make_path [build_dir; tool_output_filename]
+ in
+ let env =
+ Environments.add_if_undefined
+ tool_output_variable
+ tool_output_file env
+ in
+ Sys.force_remove tool_output_file;
+ let env =
+ Environments.add Builtin_variables.test_build_directory build_dir env in
+ Actions_helpers.setup_build_env false source_modules log env
+
+let setup_compiler_build_env (compiler : Ocaml_compilers.compiler) log env =
+ let (r, env) = setup_tool_build_env compiler log env in
+ if Result.is_pass r then
+ begin
+ let prog_var = compiler#program_variable in
+ let prog_output_var = compiler#program_output_variable in
+ let default_prog_file = get_program_file compiler#target env in
+ let env = Environments.add_if_undefined prog_var default_prog_file env in
+ let prog_file = Environments.safe_lookup prog_var env in
+ let prog_output_file = prog_file ^ ".output" in
+ let env = match prog_output_var with
+ | None -> env
+ | Some outputvar ->
+ Environments.add_if_undefined outputvar prog_output_file env
+ in
+ (r, env)
+ end else (r, env)
+
+let setup_toplevel_build_env (toplevel : Ocaml_toplevels.toplevel) log env =
+ setup_tool_build_env toplevel log env
+
+let mk_compiler_env_setup name (compiler : Ocaml_compilers.compiler) =
+ Actions.make name (setup_compiler_build_env compiler)
+
+let mk_toplevel_env_setup name (toplevel : Ocaml_toplevels.toplevel) =
+ Actions.make name (setup_toplevel_build_env toplevel)
+
+let setup_ocamlc_byte_build_env =
+ mk_compiler_env_setup
+ "setup-ocamlc.byte-build-env"
+ Ocaml_compilers.ocamlc_byte
+
+let setup_ocamlc_opt_build_env =
+ native_action
+ (mk_compiler_env_setup
+ "setup-ocamlc.opt-build-env"
+ Ocaml_compilers.ocamlc_opt)
+
+let setup_ocamlopt_byte_build_env =
+ native_action
+ (mk_compiler_env_setup
+ "setup-ocamlopt.byte-build-env"
+ Ocaml_compilers.ocamlopt_byte)
+
+let setup_ocamlopt_opt_build_env =
+ native_action
+ (mk_compiler_env_setup
+ "setup-ocamlopt.opt-build-env"
+ Ocaml_compilers.ocamlopt_opt)
+
+let setup_ocaml_build_env =
+ mk_toplevel_env_setup
+ "setup-ocaml-build-env"
+ Ocaml_toplevels.ocaml
+
+let setup_ocamlnat_build_env =
+ native_action
+ (mk_toplevel_env_setup
+ "setup-ocamlnat-build-env"
+ Ocaml_toplevels.ocamlnat)
+
+let compile (compiler : Ocaml_compilers.compiler) log env =
+ let ocamlsrcdir = Ocaml_directories.srcdir () in
+ match Environments.lookup_nonempty Ocaml_variables.module_ env with
+ | None -> compile_program ocamlsrcdir compiler log env
+ | Some module_ -> compile_module ocamlsrcdir compiler module_ log env
+
+(* Compile actions *)
+
+let ocamlc_byte =
+ Actions.make
+ "ocamlc.byte"
+ (compile Ocaml_compilers.ocamlc_byte)
+
+let ocamlc_opt =
+ native_action
+ (Actions.make
+ "ocamlc.opt"
+ (compile Ocaml_compilers.ocamlc_opt))
+
+let ocamlopt_byte =
+ native_action
+ (Actions.make
+ "ocamlopt.byte"
+ (compile Ocaml_compilers.ocamlopt_byte))
+
+let ocamlopt_opt =
+ native_action
+ (Actions.make
+ "ocamlopt.opt"
+ (compile Ocaml_compilers.ocamlopt_opt))
+
+let env_with_lib_unix ocamlsrcdir env =
+ let libunixdir = Ocaml_directories.libunix ocamlsrcdir in
+ let newlibs =
+ match Environments.lookup Ocaml_variables.caml_ld_library_path env with
+ | None -> libunixdir
+ | Some libs -> libunixdir ^ " " ^ libs
+ in
+ Environments.add Ocaml_variables.caml_ld_library_path newlibs env
+
+let debug log env =
+ let ocamlsrcdir = Ocaml_directories.srcdir () in
+ let program = Environments.safe_lookup Builtin_variables.program env in
+ let what = Printf.sprintf "Debugging program %s" program in
+ Printf.fprintf log "%s\n%!" what;
+ let commandline =
+ [
+ Ocaml_commands.ocamlrun_ocamldebug ocamlsrcdir;
+ Ocaml_flags.ocamldebug_default_flags ocamlsrcdir;
+ program
+ ] in
+ let systemenv =
+ Array.append
+ dumb_term
+ (Environments.to_system_env (env_with_lib_unix ocamlsrcdir env))
+ in
+ let expected_exit_status = 0 in
+ let exit_status =
+ Actions_helpers.run_cmd
+ ~environment:systemenv
+ ~stdin_variable: Ocaml_variables.ocamldebug_script
+ ~stdout_variable:Builtin_variables.output
+ ~stderr_variable:Builtin_variables.output
+ ~append:true
+ log (env_with_lib_unix ocamlsrcdir env) commandline in
+ if exit_status=expected_exit_status
+ then (Result.pass, env)
+ else begin
+ let reason =
+ (Actions_helpers.mkreason
+ what (String.concat " " commandline) exit_status) in
+ (Result.fail_with_reason reason, env)
+ end
+
+let ocamldebug = Actions.make "ocamldebug" debug
+
+let objinfo log env =
+ let ocamlsrcdir = Ocaml_directories.srcdir () in
+ let tools_directory = Ocaml_directories.tools ocamlsrcdir in
+ let program = Environments.safe_lookup Builtin_variables.program env in
+ let what = Printf.sprintf "Running ocamlobjinfo on %s" program in
+ Printf.fprintf log "%s\n%!" what;
+ let commandline =
+ [
+ Ocaml_commands.ocamlrun_ocamlobjinfo ocamlsrcdir;
+ Ocaml_flags.ocamlobjinfo_default_flags;
+ program
+ ] in
+ let ocamllib = [| (Printf.sprintf "OCAMLLIB=%s" tools_directory) |] in
+ let systemenv =
+ Array.concat
+ [
+ dumb_term;
+ ocamllib;
+ (Environments.to_system_env (env_with_lib_unix ocamlsrcdir env))
+ ]
+ in
+ let expected_exit_status = 0 in
+ let exit_status =
+ Actions_helpers.run_cmd
+ ~environment:systemenv
+ ~stdout_variable:Builtin_variables.output
+ ~stderr_variable:Builtin_variables.output
+ ~append:true
+ log (env_with_lib_unix ocamlsrcdir env) commandline in
+ if exit_status=expected_exit_status
+ then (Result.pass, env)
+ else begin
+ let reason =
+ (Actions_helpers.mkreason
+ what (String.concat " " commandline) exit_status) in
+ (Result.fail_with_reason reason, env)
+ end
+
+let ocamlobjinfo = Actions.make "ocamlobjinfo" objinfo
+
+let run_expect_once ocamlsrcdir input_file principal log env =
+ let expect_flags = Sys.safe_getenv "EXPECT_FLAGS" in
+ let repo_root = "-repo-root " ^ ocamlsrcdir in
+ let principal_flag = if principal then "-principal" else "" in
+ let commandline =
+ [
+ Ocaml_commands.ocamlrun_expect_test ocamlsrcdir;
+ expect_flags;
+ flags env;
+ repo_root;
+ principal_flag;
+ input_file
+ ] in
+ let exit_status =
+ Actions_helpers.run_cmd ~environment:dumb_term log env commandline in
+ if exit_status=0 then (Result.pass, env)
+ else begin
+ let reason = (Actions_helpers.mkreason
+ "expect" (String.concat " " commandline) exit_status) in
+ (Result.fail_with_reason reason, env)
+ end
+
+let run_expect_twice ocamlsrcdir input_file log env =
+ let corrected filename = Filename.make_filename filename "corrected" in
+ let (result1, env1) = run_expect_once ocamlsrcdir input_file false log env in
+ if Result.is_pass result1 then begin
+ let intermediate_file = corrected input_file in
+ let (result2, env2) =
+ run_expect_once ocamlsrcdir intermediate_file true log env1 in
+ if Result.is_pass result2 then begin
+ let output_file = corrected intermediate_file in
+ let output_env = Environments.add_bindings
+ [
+ Builtin_variables.reference, input_file;
+ Builtin_variables.output, output_file
+ ] env2 in
+ (Result.pass, output_env)
+ end else (result2, env2)
+ end else (result1, env1)
+
+let run_expect log env =
+ let ocamlsrcdir = Ocaml_directories.srcdir () in
+ let input_file = Actions_helpers.testfile env in
+ run_expect_twice ocamlsrcdir input_file log env
+
+let run_expect = Actions.make "run-expect" run_expect
+
+let make_check_tool_output name tool = Actions.make
+ name
+ (Actions_helpers.check_output
+ tool#family
+ tool#output_variable
+ tool#reference_variable)
+
+let check_ocamlc_byte_output = make_check_tool_output
+ "check-ocamlc.byte-output" Ocaml_compilers.ocamlc_byte
+
+let check_ocamlc_opt_output =
+ native_action
+ (make_check_tool_output
+ "check-ocamlc.opt-output" Ocaml_compilers.ocamlc_opt)
+
+let check_ocamlopt_byte_output =
+ native_action
+ (make_check_tool_output
+ "check-ocamlopt.byte-output" Ocaml_compilers.ocamlopt_byte)
+
+let check_ocamlopt_opt_output =
+ native_action
+ (make_check_tool_output
+ "check-ocamlopt.opt-output" Ocaml_compilers.ocamlopt_opt)
+
+let really_compare_programs backend comparison_tool log env =
+ let program = Environments.safe_lookup Builtin_variables.program env in
+ let program2 = Environments.safe_lookup Builtin_variables.program2 env in
+ let what = Printf.sprintf "Comparing %s programs %s and %s"
+ (Ocaml_backends.string_of_backend backend) program program2 in
+ Printf.fprintf log "%s\n%!" what;
+ let files = {
+ Filecompare.filetype = Filecompare.Binary;
+ Filecompare.reference_filename = program;
+ Filecompare.output_filename = program2
+ } in
+ if Ocamltest_config.flambda && backend = Ocaml_backends.Native
+ then begin
+ let reason =
+ "flambda temporarily disables comparison of native programs" in
+ (Result.pass_with_reason reason, env)
+ end else
+ if backend = Ocaml_backends.Native &&
+ (Sys.os_type="Win32" || Sys.os_type="Cygwin")
+ then begin
+ let reason =
+ "comparison of native programs temporarily disabled under Windows" in
+ (Result.pass_with_reason reason, env)
+ end else begin
+ let comparison_tool =
+ if backend=Ocaml_backends.Native &&
+ (Sys.os_type="Win32" || Sys.os_type="Cygwin")
+ then
+ let bytes_to_ignore = 512 (* comparison_start_address program *) in
+ Filecompare.(make_cmp_tool ~ignore:{bytes=bytes_to_ignore; lines=0})
+ else comparison_tool in
+ match Filecompare.compare_files ~tool:comparison_tool files with
+ | Filecompare.Same -> (Result.pass, env)
+ | Filecompare.Different ->
+ let reason = Printf.sprintf "Files %s and %s are different"
+ program program2 in
+ (Result.fail_with_reason reason, env)
+ | Filecompare.Unexpected_output -> assert false
+ | Filecompare.Error (commandline, exitcode) ->
+ let reason = Actions_helpers.mkreason what commandline exitcode in
+ (Result.fail_with_reason reason, env)
+ end
+
+let compare_programs backend comparison_tool log env =
+ let compare_programs =
+ Environments.lookup_as_bool Ocaml_variables.compare_programs env in
+ if compare_programs = Some false then begin
+ let reason = "program comparison disabled" in
+ (Result.pass_with_reason reason, env)
+ end else really_compare_programs backend comparison_tool log env
+
+let make_bytecode_programs_comparison_tool ocamlsrcdir =
+ let ocamlrun = Ocaml_files.ocamlrun ocamlsrcdir in
+ let cmpbyt = Ocaml_files.cmpbyt ocamlsrcdir in
+ let tool_name = ocamlrun ^ " " ^ cmpbyt in
+ Filecompare.make_comparison_tool tool_name ""
+
+let native_programs_comparison_tool = Filecompare.default_comparison_tool
+
+let compare_bytecode_programs_code log env =
+ let ocamlsrcdir = Ocaml_directories.srcdir () in
+ let bytecode_programs_comparison_tool =
+ make_bytecode_programs_comparison_tool ocamlsrcdir in
+ compare_programs
+ Ocaml_backends.Bytecode bytecode_programs_comparison_tool log env
+
+let compare_bytecode_programs =
+ native_action
+ (Actions.make
+ "compare-bytecode-programs"
+ compare_bytecode_programs_code)
+
+let compare_native_programs =
+ native_action
+ (Actions.make
+ "compare-native-programs"
+ (compare_programs Ocaml_backends.Native native_programs_comparison_tool))
+
+let compile_module
+ ocamlsrcdir compiler compilername compileroutput log env
+ (module_basename, module_filetype) =
+ let backend = compiler#target in
+ let filename =
+ Ocaml_filetypes.make_filename (module_basename, module_filetype) in
+ let expected_exit_status =
+ Ocaml_tools.expected_exit_status env (compiler :> Ocaml_tools.tool) in
+ let what = Printf.sprintf "%s for file %s (expected exit status: %d)"
+ (Ocaml_filetypes.action_of_filetype module_filetype) filename
+ (expected_exit_status) in
+ let compile_commandline input_file output_file optional_flags =
+ let compile = "-c " ^ input_file in
+ let output = match output_file with
+ | None -> ""
+ | Some file -> "-o " ^ file in
+ [
+ compilername;
+ Ocaml_flags.stdlib ocamlsrcdir;
+ flags env;
+ backend_flags env backend;
+ optional_flags;
+ compile;
+ output;
+ ] in
+ let exec commandline =
+ Printf.fprintf log "%s\n%!" what;
+ let exit_status =
+ Actions_helpers.run_cmd
+ ~stdin_variable: Ocaml_variables.compiler_stdin
+ ~stdout_variable:compileroutput
+ ~stderr_variable:compileroutput
+ ~append:true log env commandline in
+ if exit_status=expected_exit_status
+ then (Result.pass, env)
+ else begin
+ let reason =
+ (Actions_helpers.mkreason
+ what (String.concat " " commandline) exit_status) in
+ (Result.fail_with_reason reason, env)
+ end in
+ match module_filetype with
+ | Ocaml_filetypes.Interface ->
+ let interface_name =
+ Ocaml_filetypes.make_filename
+ (module_basename, Ocaml_filetypes.Interface) in
+ let commandline = compile_commandline interface_name None "" in
+ exec commandline
+ | Ocaml_filetypes.Implementation ->
+ let module_extension = Ocaml_backends.module_extension backend in
+ let module_output_name =
+ Filename.make_filename module_basename module_extension in
+ let commandline =
+ compile_commandline filename (Some module_output_name) "" in
+ exec commandline
+ | Ocaml_filetypes.C ->
+ let object_extension = Config.ext_obj in
+ let _object_filename = module_basename ^ object_extension in
+ let commandline =
+ compile_commandline filename None
+ (Ocaml_flags.c_includes ocamlsrcdir) in
+ exec commandline
+ | _ ->
+ let reason = Printf.sprintf "File %s of type %s not supported yet"
+ filename (Ocaml_filetypes.string_of_filetype module_filetype) in
+ (Result.fail_with_reason reason, env)
+
+let compile_modules
+ ocamlsrcdir compiler compilername compileroutput
+ modules_with_filetypes log initial_env
+ =
+ let compile_mod env mod_ =
+ compile_module ocamlsrcdir compiler compilername compileroutput
+ log env mod_ in
+ let rec compile_mods env = function
+ | [] -> (Result.pass, env)
+ | m::ms ->
+ (let (result, newenv) = compile_mod env m in
+ if Result.is_pass result then (compile_mods newenv ms)
+ else (result, newenv)) in
+ compile_mods initial_env modules_with_filetypes
+
+let run_test_program_in_toplevel (toplevel : Ocaml_toplevels.toplevel) log env =
+ let testfile = Actions_helpers.testfile env in
+ let expected_exit_status =
+ Ocaml_tools.expected_exit_status env (toplevel :> Ocaml_tools.tool) in
+ let compiler_output_variable = toplevel#output_variable in
+ let ocamlsrcdir = Ocaml_directories.srcdir () in
+ let compiler = toplevel#compiler in
+ let compiler_name = compiler#name ocamlsrcdir in
+ let modules_with_filetypes =
+ List.map Ocaml_filetypes.filetype (modules env) in
+ let (result, env) = compile_modules
+ ocamlsrcdir compiler compiler_name compiler_output_variable
+ modules_with_filetypes log env in
+ if Result.is_pass result then begin
+ let what =
+ Printf.sprintf "Running %s in %s toplevel (expected exit status: %d)"
+ testfile
+ (Ocaml_backends.string_of_backend toplevel#backend)
+ expected_exit_status in
+ Printf.fprintf log "%s\n%!" what;
+ let toplevel_name = toplevel#name ocamlsrcdir in
+ let ocaml_script_as_argument =
+ match
+ Environments.lookup_as_bool
+ Ocaml_variables.ocaml_script_as_argument env
+ with
+ | None -> false
+ | Some b -> b
+ in
+ let commandline =
+ [
+ toplevel_name;
+ Ocaml_flags.toplevel_default_flags;
+ toplevel#flags;
+ Ocaml_flags.stdlib ocamlsrcdir;
+ directory_flags env;
+ Ocaml_flags.include_toplevel_directory ocamlsrcdir;
+ flags env;
+ libraries toplevel#backend env;
+ binary_modules toplevel#backend env;
+ if ocaml_script_as_argument then testfile else "";
+ Environments.safe_lookup Builtin_variables.arguments env
+ ] in
+ let exit_status =
+ if ocaml_script_as_argument
+ then Actions_helpers.run_cmd
+ ~environment:dumb_term
+ ~stdout_variable:compiler_output_variable
+ ~stderr_variable:compiler_output_variable
+ log env commandline
+ else Actions_helpers.run_cmd
+ ~environment:dumb_term
+ ~stdin_variable:Builtin_variables.test_file
+ ~stdout_variable:compiler_output_variable
+ ~stderr_variable:compiler_output_variable
+ log env commandline
+ in
+ if exit_status=expected_exit_status
+ then (Result.pass, env)
+ else begin
+ let reason =
+ (Actions_helpers.mkreason
+ what (String.concat " " commandline) exit_status) in
+ (Result.fail_with_reason reason, env)
+ end
+ end else (result, env)
+
+let ocaml = Actions.make
+ "ocaml"
+ (run_test_program_in_toplevel Ocaml_toplevels.ocaml)
+
+let ocamlnat =
+ native_action
+ (Actions.make
+ "ocamlnat"
+ (run_test_program_in_toplevel Ocaml_toplevels.ocamlnat))
+
+let check_ocaml_output = make_check_tool_output
+ "check-ocaml-output" Ocaml_toplevels.ocaml
+
+let check_ocamlnat_output =
+ native_action
+ (make_check_tool_output
+ "check-ocamlnat-output" Ocaml_toplevels.ocamlnat)
+
+let config_variables _log env = Environments.add_bindings
+ [
+ Ocaml_variables.c_preprocessor, Ocamltest_config.c_preprocessor;
+ Ocaml_variables.ocamlc_default_flags,
+ Ocamltest_config.ocamlc_default_flags;
+ Ocaml_variables.ocamlopt_default_flags,
+ Ocamltest_config.ocamlopt_default_flags;
+ Ocaml_variables.ocamlrunparam, Sys.safe_getenv "OCAMLRUNPARAM";
+ Ocaml_variables.ocamlsrcdir, Ocaml_directories.srcdir();
+ Ocaml_variables.os_type, Sys.os_type;
+ ] env
+
+let flat_float_array = Actions.make
+ "flat-float-array"
+ (Actions_helpers.pass_or_skip Ocamltest_config.flat_float_array
+ "compiler configured with -flat-float-array"
+ "compiler configured with -no-flat-float-array")
+
+let no_flat_float_array = make
+ "no-flat-float-array"
+ (Actions_helpers.pass_or_skip (not Ocamltest_config.flat_float_array)
+ "compiler configured with -no-flat-float-array"
+ "compiler configured with -flat-float-array")
+
+let flambda = Actions.make
+ "flambda"
+ (Actions_helpers.pass_or_skip Ocamltest_config.flambda
+ "support for flambda enabled"
+ "support for flambda disabled")
+
+let no_flambda = make
+ "no-flambda"
+ (Actions_helpers.pass_or_skip (not Ocamltest_config.flambda)
+ "support for flambda disabled"
+ "support for flambda enabled")
+
+let spacetime = Actions.make
+ "spacetime"
+ (Actions_helpers.pass_or_skip Ocamltest_config.spacetime
+ "support for spacetime enabled"
+ "support for spacetime disabled")
+
+let no_spacetime = make
+ "no-spacetime"
+ (Actions_helpers.pass_or_skip (not Ocamltest_config.spacetime)
+ "support for spacetime disabled"
+ "support for spacetime enabled")
+
+let shared_libraries = Actions.make
+ "shared-libraries"
+ (Actions_helpers.pass_or_skip Ocamltest_config.shared_libraries
+ "Shared libraries are supported."
+ "Shared libraries are not supported.")
+
+let native_compiler = Actions.make
+ "native-compiler"
+ (Actions_helpers.pass_or_skip (Ocamltest_config.arch <> "none")
+ "native compiler available"
+ "native compiler not available")
+
+let afl_instrument = Actions.make
+ "afl-instrument"
+ (Actions_helpers.pass_or_skip Ocamltest_config.afl_instrument
+ "AFL instrumentation enabled"
+ "AFL instrumentation disabled")
+
+let no_afl_instrument = Actions.make
+ "no-afl-instrument"
+ (Actions_helpers.pass_or_skip (not Ocamltest_config.afl_instrument)
+ "AFL instrumentation disabled"
+ "AFL instrumentation enabled")
+
+let ocamldoc = Ocaml_tools.ocamldoc
+
+let ocamldoc_output_file env prefix =
+ let backend =
+ Environments.safe_lookup Ocaml_variables.ocamldoc_backend env in
+ let suffix = match backend with
+ | "latex" -> ".tex"
+ | "html" -> ".html"
+ | "man" -> ".3o"
+ | _ -> ".result" in
+ prefix ^ suffix
+
+let check_ocamldoc_output = make_check_tool_output
+ "check-ocamldoc-output" ocamldoc
+
+let ocamldoc_flags env =
+ Environments.safe_lookup Ocaml_variables.ocamldoc_flags env
+
+let compiled_doc_name input = input ^ ".odoc"
+
+(* The compiler used for compiling both cmi file
+ and plugins *)
+let compiler_for_ocamldoc ocamlsrcdir =
+ let compiler = Ocaml_compilers.ocamlc_byte in
+ compile_modules ocamlsrcdir compiler (compiler#name ocamlsrcdir)
+ compiler#output_variable
+
+(* Within ocamldoc tests,
+ modules="a.ml b.ml" is interpreted as a list of
+ secondaries documentation modules that need to be
+ compiled into cmi files and odoc file (serialized ocamldoc information)
+ before the main documentation is generated *)
+let compile_ocamldoc ocamlsrcdir (basename,filetype as module_) log env =
+ let expected_exit_status =
+ Ocaml_tools.expected_exit_status env (ocamldoc :> Ocaml_tools.tool) in
+ let what = Printf.sprintf "Compiling documentation for module %s" basename in
+ Printf.fprintf log "%s\n%!" what;
+ let filename =
+ Ocaml_filetypes.make_filename (basename, filetype) in
+ let (r,env) = compiler_for_ocamldoc ocamlsrcdir [module_] log env in
+ if not (Result.is_pass r) then (r,env) else
+ let commandline =
+ (* currently, we are ignoring the global ocamldoc_flags, since we
+ don't have per-module flags *)
+ [
+ Ocaml_commands.ocamlrun_ocamldoc ocamlsrcdir;
+ Ocaml_flags.stdlib ocamlsrcdir;
+ "-dump " ^ compiled_doc_name basename;
+ filename;
+ ] in
+ let exit_status =
+ Actions_helpers.run_cmd
+ ~environment:(Environments.to_system_env env)
+ ~stdin_variable: Ocaml_variables.compiler_stdin
+ ~stdout_variable:ocamldoc#output_variable
+ ~stderr_variable:ocamldoc#output_variable
+ ~append:true
+ log env commandline in
+ if exit_status=expected_exit_status
+ then (Result.pass, env)
+ else begin
+ let reason =
+ (Actions_helpers.mkreason
+ what (String.concat " " commandline) exit_status) in
+ (Result.fail_with_reason reason, env)
+ end
+
+let rec ocamldoc_compile_all ocamlsrcdir log env = function
+ | [] -> (Result.pass, env)
+ | a :: q ->
+ let (r,env) = compile_ocamldoc ocamlsrcdir a log env in
+ if Result.is_pass r then
+ ocamldoc_compile_all ocamlsrcdir log env q
+ else
+ (r,env)
+
+let setup_ocamldoc_build_env =
+ Actions.make "setup_ocamldoc_build_env" @@ fun log env ->
+ let (r,env) = setup_tool_build_env ocamldoc log env in
+ if not (Result.is_pass r) then (r,env) else
+ let source_directory = Actions_helpers.test_source_directory env in
+ let root_file = Filename.chop_extension (Actions_helpers.testfile env) in
+ let reference_prefix = Filename.make_path [source_directory; root_file] in
+ let output = ocamldoc_output_file env root_file in
+ let reference= reference_prefix ^ ocamldoc#reference_filename_suffix env in
+ let backend = Environments.safe_lookup Ocaml_variables.ocamldoc_backend env in
+ let env =
+ Environments.apply_modifiers env Ocaml_modifiers.(str @ unix)
+ |> Environments.add Builtin_variables.reference reference
+ |> Environments.add Builtin_variables.output output in
+ let env =
+ if backend = "man" then Environments.add_if_undefined
+ Builtin_variables.skip_header_lines "1" env
+ else env in
+ Result.pass, env
+
+let ocamldoc_plugin name = name ^ ".cmo"
+
+let ocamldoc_backend_flag env =
+ let backend = Environments.safe_lookup Ocaml_variables.ocamldoc_backend env in
+ if backend = "" then "" else "-" ^ backend
+
+let ocamldoc_o_flag env =
+ let output = Environments.safe_lookup Builtin_variables.output env in
+ match Environments.safe_lookup Ocaml_variables.ocamldoc_backend env with
+ | "html" | "manual" -> "index"
+ | _ -> output
+
+let run_ocamldoc =
+ Actions.make "ocamldoc" @@ fun log env ->
+ (* modules corresponds to secondaries modules of which the
+ documentation and cmi files need to be build before the main
+ module documentation *)
+ let modules = List.map Ocaml_filetypes.filetype @@ modules env in
+ (* plugins are used for custom documentation generators *)
+ let plugins = List.map Ocaml_filetypes.filetype @@ plugins env in
+ let ocamlsrcdir = Ocaml_directories.srcdir () in
+ let (r,env) = compiler_for_ocamldoc ocamlsrcdir plugins log env in
+ if not (Result.is_pass r) then r, env else
+ let (r,env) = ocamldoc_compile_all ocamlsrcdir log env modules in
+ if not (Result.is_pass r) then r, env else
+ let input_file = Actions_helpers.testfile env in
+ Printf.fprintf log "Generating documentation for %s\n%!" input_file;
+ let load_all =
+ List.map (fun name -> "-load " ^ compiled_doc_name (fst name))
+ @@ (* sort module in alphabetical order *)
+ List.sort Pervasives.compare modules in
+ let with_plugins =
+ List.map (fun name -> "-g " ^ ocamldoc_plugin (fst name)) plugins in
+ let commandline =
+ [
+ Ocaml_commands.ocamlrun_ocamldoc ocamlsrcdir;
+ ocamldoc_backend_flag env;
+ Ocaml_flags.stdlib ocamlsrcdir;
+ ocamldoc_flags env]
+ @ load_all @ with_plugins @
+ [ input_file;
+ "-o"; ocamldoc_o_flag env
+ ] in
+ let exit_status =
+ Actions_helpers.run_cmd ~environment:(Environments.to_system_env env)
+ ~stdin_variable: Ocaml_variables.compiler_stdin
+ ~stdout_variable:ocamldoc#output_variable
+ ~stderr_variable:ocamldoc#output_variable
+ ~append:true
+ log env commandline in
+ if exit_status=0 then
+ (Result.pass, env)
+ else begin
+ let reason = (Actions_helpers.mkreason
+ "ocamldoc" (String.concat " " commandline) exit_status) in
+ (Result.fail_with_reason reason, env)
+ end
+
+let _ =
+ Environments.register_initializer "find_source_modules" find_source_modules;
+ Environments.register_initializer "config_variables" config_variables;
+ List.iter register
+ [
+ setup_ocamlc_byte_build_env;
+ ocamlc_byte;
+ check_ocamlc_byte_output;
+ setup_ocamlc_opt_build_env;
+ ocamlc_opt;
+ check_ocamlc_opt_output;
+ setup_ocamlopt_byte_build_env;
+ ocamlopt_byte;
+ check_ocamlopt_byte_output;
+ setup_ocamlopt_opt_build_env;
+ ocamlopt_opt;
+ check_ocamlopt_opt_output;
+ run_expect;
+ compare_bytecode_programs;
+ compare_native_programs;
+ setup_ocaml_build_env;
+ ocaml;
+ check_ocaml_output;
+ setup_ocamlnat_build_env;
+ ocamlnat;
+ check_ocamlnat_output;
+ flat_float_array;
+ no_flat_float_array;
+ flambda;
+ no_flambda;
+ spacetime;
+ no_spacetime;
+ shared_libraries;
+ native_compiler;
+ afl_instrument;
+ no_afl_instrument;
+ setup_ocamldoc_build_env;
+ run_ocamldoc;
+ check_ocamldoc_output;
+ ocamldebug;
+ ocamlobjinfo
+ ]
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2017 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Actions specific to the OCaml compilers *)
+
+val setup_ocamlc_byte_build_env : Actions.t
+val ocamlc_byte : Actions.t
+val check_ocamlc_byte_output : Actions.t
+val setup_ocamlc_opt_build_env : Actions.t
+val ocamlc_opt : Actions.t
+val check_ocamlc_opt_output : Actions.t
+val setup_ocamlopt_byte_build_env : Actions.t
+val ocamlopt_byte : Actions.t
+val check_ocamlopt_byte_output : Actions.t
+val setup_ocamlopt_opt_build_env : Actions.t
+val ocamlopt_opt : Actions.t
+val check_ocamlopt_opt_output : Actions.t
+val run_expect : Actions.t
+val compare_bytecode_programs : Actions.t
+val compare_native_programs : Actions.t
+val setup_ocaml_build_env : Actions.t
+val ocaml : Actions.t
+val check_ocaml_output : Actions.t
+val setup_ocamlnat_build_env : Actions.t
+val ocamlnat : Actions.t
+val check_ocamlnat_output : Actions.t
+
+val setup_ocamldoc_build_env : Actions.t
+val run_ocamldoc: Actions.t
+val check_ocamldoc_output: Actions.t
+
+val flat_float_array : Actions.t
+val no_flat_float_array : Actions.t
+
+val shared_libraries : Actions.t
+
+val native_compiler : Actions.t
+
+val afl_instrument : Actions.t
+val no_afl_instrument : Actions.t
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2016 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Backends of the OCaml compiler and their properties *)
+
+type t = Native | Bytecode
+
+let is_bytecode t = t=Bytecode
+
+let is_native t = t=Native
+
+let string_of_backend = function
+ | Native -> "native"
+ | Bytecode -> "bytecode"
+
+(* Creates a function that returns its first argument for Bytecode *)
+(* and its second argument for Native code *)
+let make_backend_function bytecode_value native_value = function
+ | Bytecode -> bytecode_value
+ | Native -> native_value
+
+let module_extension = make_backend_function "cmo" "cmx"
+
+let library_extension = make_backend_function "cma" "cmxa"
+
+let executable_extension = make_backend_function "byte" "opt"
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2016 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Backends of the OCaml compiler and their properties *)
+
+type t = Native | Bytecode
+
+val is_bytecode : t -> bool
+
+val is_native : t -> bool
+
+val string_of_backend : t -> string
+
+val make_backend_function : 'a -> 'a -> t -> 'a
+
+val module_extension : t -> string
+
+val library_extension : t -> string
+
+val executable_extension : t -> string
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Helper functions to build OCaml-related commands *)
+
+let ocamlrun ocamlsrcdir program =
+ (Ocaml_files.ocamlrun ocamlsrcdir) ^ " " ^ (program ocamlsrcdir)
+
+let ocamlrun_ocamlc ocamlsrcdir = ocamlrun ocamlsrcdir Ocaml_files.ocamlc
+
+let ocamlrun_ocamlopt ocamlsrcdir = ocamlrun ocamlsrcdir Ocaml_files.ocamlopt
+
+let ocamlrun_ocaml ocamlsrcdir = ocamlrun ocamlsrcdir Ocaml_files.ocaml
+
+let ocamlrun_expect_test ocamlsrcdir =
+ ocamlrun ocamlsrcdir Ocaml_files.expect_test
+
+let ocamlrun_ocamllex ocamlsrcdir = ocamlrun ocamlsrcdir Ocaml_files.ocamllex
+
+let ocamlrun_ocamldoc ocamlsrcdir =
+ ocamlrun ocamlsrcdir Ocaml_files.ocamldoc
+
+let ocamlrun_ocamldebug ocamlsrcdir =
+ ocamlrun ocamlsrcdir Ocaml_files.ocamldebug
+
+let ocamlrun_ocamlobjinfo ocamlsrcdir =
+ ocamlrun ocamlsrcdir Ocaml_files.ocamlobjinfo
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Helper functions to build OCaml-related commands *)
+
+val ocamlrun_ocamlc : string -> string
+
+val ocamlrun_ocamlopt : string -> string
+
+val ocamlrun_ocaml : string -> string
+
+val ocamlrun_expect_test : string -> string
+
+val ocamlrun_ocamllex : string -> string
+
+val ocamlrun_ocamldoc : string -> string
+
+val ocamlrun_ocamldebug : string -> string
+
+val ocamlrun_ocamlobjinfo : string -> string
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Description of the OCaml compilers *)
+
+open Ocamltest_stdlib
+
+class compiler
+ ~(name : string -> string)
+ ~(flags : string)
+ ~(directory : string)
+ ~(exit_status_variable : Variables.t)
+ ~(reference_variable : Variables.t)
+ ~(output_variable : Variables.t)
+ ~(host : Ocaml_backends.t)
+ ~(target : Ocaml_backends.t)
+= object (self) inherit Ocaml_tools.tool
+ ~name:name
+ ~family:"compiler"
+ ~flags:flags
+ ~directory:directory
+ ~exit_status_variable:exit_status_variable
+ ~reference_variable:reference_variable
+ ~output_variable:output_variable
+ as tool
+
+ method host = host
+ method target = target
+
+ method program_variable =
+ if Ocaml_backends.is_native host
+ then Builtin_variables.program2
+ else Builtin_variables.program
+
+ method program_output_variable =
+ if Ocaml_backends.is_native host
+ then None
+ else Some Builtin_variables.output
+
+ method ! reference_file env prefix =
+ let default = tool#reference_file env prefix in
+ if Sys.file_exists default then default else
+ let suffix = self#reference_filename_suffix env in
+ let mk s = (Filename.make_filename prefix s) ^ suffix in
+ let filename = mk
+ (Ocaml_backends.string_of_backend target) in
+ if Sys.file_exists filename then filename else
+ mk "compilers"
+end
+
+let ocamlc_byte = new compiler
+ ~name: Ocaml_commands.ocamlrun_ocamlc
+ ~flags: ""
+ ~directory: "ocamlc.byte"
+ ~exit_status_variable: Ocaml_variables.ocamlc_byte_exit_status
+ ~reference_variable: Ocaml_variables.compiler_reference
+ ~output_variable: Ocaml_variables.compiler_output
+ ~host: Ocaml_backends.Bytecode
+ ~target: Ocaml_backends.Bytecode
+
+let ocamlc_opt = new compiler
+ ~name: Ocaml_files.ocamlc_dot_opt
+ ~flags: ""
+ ~directory: "ocamlc.opt"
+ ~exit_status_variable: Ocaml_variables.ocamlc_opt_exit_status
+ ~reference_variable: Ocaml_variables.compiler_reference2
+ ~output_variable: Ocaml_variables.compiler_output2
+ ~host: Ocaml_backends.Native
+ ~target: Ocaml_backends.Bytecode
+
+let ocamlopt_byte = new compiler
+ ~name: Ocaml_commands.ocamlrun_ocamlopt
+ ~flags: ""
+ ~directory: "ocamlopt.byte"
+ ~exit_status_variable: Ocaml_variables.ocamlopt_byte_exit_status
+ ~reference_variable: Ocaml_variables.compiler_reference
+ ~output_variable: Ocaml_variables.compiler_output
+ ~host: Ocaml_backends.Bytecode
+ ~target: Ocaml_backends.Native
+
+let ocamlopt_opt = new compiler
+ ~name: Ocaml_files.ocamlopt_dot_opt
+ ~flags: ""
+ ~directory: "ocamlopt.opt"
+ ~exit_status_variable: Ocaml_variables.ocamlopt_opt_exit_status
+ ~reference_variable: Ocaml_variables.compiler_reference2
+ ~output_variable: Ocaml_variables.compiler_output2
+ ~host: Ocaml_backends.Native
+ ~target: Ocaml_backends.Native
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Descriptions of the OCaml compilers *)
+
+class compiler :
+ name : (string -> string) ->
+ flags : string ->
+ directory : string ->
+ exit_status_variable : Variables.t ->
+ reference_variable : Variables.t ->
+ output_variable : Variables.t ->
+ host : Ocaml_backends.t ->
+ target : Ocaml_backends.t ->
+object inherit Ocaml_tools.tool
+ method host : Ocaml_backends.t
+ method target : Ocaml_backends.t
+ method program_variable : Variables.t
+ method program_output_variable : Variables.t option
+end
+
+val ocamlc_byte : compiler
+
+val ocamlc_opt : compiler
+
+val ocamlopt_byte : compiler
+
+val ocamlopt_opt : compiler
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Locations of directories in the OCaml source tree *)
+
+open Ocamltest_stdlib
+
+let srcdir () =
+ Sys.getenv_with_default_value "OCAMLSRCDIR" Ocamltest_config.ocamlsrcdir
+
+let stdlib ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "stdlib"]
+
+let libunix ocamlsrcdir =
+ let subdir = if Sys.os_type="Win32" then "win32unix" else "unix" in
+ Filename.make_path [ocamlsrcdir; "otherlibs"; subdir]
+
+let toplevel ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "toplevel"]
+
+let runtime ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "byterun"]
+
+let runtime_library backend ocamlsrcdir =
+ let backend_lib_dir = match backend with
+ | Ocaml_backends.Native -> "asmrun"
+ | Ocaml_backends.Bytecode -> "byterun" in
+ Filename.make_path [ocamlsrcdir; backend_lib_dir]
+
+let tools ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "tools"]
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Locations of directories in the OCaml source tree *)
+
+val srcdir : unit -> string
+
+val stdlib : string -> string
+
+val libunix : string -> string
+
+val toplevel : string -> string
+
+val runtime : string -> string
+
+val runtime_library : Ocaml_backends.t -> string -> string
+
+val tools : string -> string
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Locations of files in the OCaml source tree *)
+
+open Ocamltest_stdlib
+
+type runtime_variant =
+ | Normal
+ | Debug
+ | Instrumented
+
+let runtime_variant() =
+ let use_runtime = Sys.safe_getenv "USE_RUNTIME" in
+ if use_runtime="d" then Debug
+ else if use_runtime="i" then Instrumented
+ else Normal
+
+let ocamlrun ocamlsrcdir =
+ let runtime = match runtime_variant () with
+ | Normal -> "ocamlrun"
+ | Debug -> "ocamlrund"
+ | Instrumented -> "ocamlruni" in
+ let ocamlrunfile = Filename.mkexe runtime in
+ Filename.make_path [ocamlsrcdir; "byterun"; ocamlrunfile]
+
+let ocamlc ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "ocamlc"]
+
+let ocaml ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "ocaml"]
+
+let ocamlc_dot_opt ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "ocamlc.opt"]
+
+let ocamlopt ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "ocamlopt"]
+
+let ocamlopt_dot_opt ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "ocamlopt.opt"]
+
+let ocamlnat ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; Filename.mkexe "ocamlnat"]
+
+let cmpbyt ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "tools"; "cmpbyt"]
+
+let expect_test ocamlsrcdir =
+ Filename.make_path
+ [ocamlsrcdir; "testsuite"; "tools"; Filename.mkexe "expect_test"]
+
+let ocamllex ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "lex"; "ocamllex"]
+
+let ocamlyacc ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "yacc"; Filename.mkexe "ocamlyacc"]
+
+let ocamldoc ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "ocamldoc"; "ocamldoc"]
+
+let ocamldebug ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "debugger"; Filename.mkexe "ocamldebug"]
+
+let ocamlobjinfo ocamlsrcdir =
+ Filename.make_path [ocamlsrcdir; "tools"; "ocamlobjinfo"]
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Locations of files in the OCaml source tree *)
+
+type runtime_variant =
+ | Normal
+ | Debug
+ | Instrumented
+
+val runtime_variant : unit -> runtime_variant
+
+val ocamlrun : string -> string
+
+val ocamlc : string -> string
+
+val ocaml : string -> string
+
+val ocamlc_dot_opt : string -> string
+
+val ocamlopt : string -> string
+
+val ocamlopt_dot_opt : string -> string
+
+val ocamlnat : string -> string
+
+val cmpbyt : string -> string
+
+val expect_test : string -> string
+
+val ocamllex : string -> string
+
+val ocamlyacc : string -> string
+
+val ocamldoc : string -> string
+val ocamldebug : string -> string
+val ocamlobjinfo : string -> string
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2016 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Types of files involved in an OCaml project and related functions *)
+
+type backend_specific = Object | Library | Program
+
+type t =
+ | Implementation
+ | Interface
+ | C
+ | C_minus_minus
+ | Lexer
+ | Grammar
+ | Binary_interface
+ | Backend_specific of Ocaml_backends.t * backend_specific
+ | Text (* used by ocamldoc for text only documentation *)
+
+let string_of_backend_specific = function
+ | Object -> "object"
+ | Library -> "library"
+ | Program -> "program"
+
+let string_of_filetype = function
+ | Implementation -> "implementation"
+ | Interface -> "interface"
+ | C -> "C source file"
+ | C_minus_minus -> "C minus minus source file"
+ | Lexer -> "lexer"
+ | Grammar -> "grammar"
+ | Binary_interface -> "binary interface"
+ | Backend_specific (backend, filetype) ->
+ ((Ocaml_backends.string_of_backend backend) ^ " " ^
+ (string_of_backend_specific filetype))
+ | Text -> "text"
+
+let extension_of_filetype = function
+ | Implementation -> "ml"
+ | Interface -> "mli"
+ | C -> "c"
+ | C_minus_minus -> "cmm"
+ | Lexer -> "mll"
+ | Grammar -> "mly"
+ | Binary_interface -> "cmi"
+ | Backend_specific (backend, filetype) ->
+ begin match (backend, filetype) with
+ | (Ocaml_backends.Native, Object) -> "cmx"
+ | (Ocaml_backends.Native, Library) -> "cmxa"
+ | (Ocaml_backends.Native, Program) -> "opt"
+ | (Ocaml_backends.Bytecode, Object) -> "cmo"
+ | (Ocaml_backends.Bytecode, Library) -> "cma"
+ | (Ocaml_backends.Bytecode, Program) -> "byte"
+ end
+ | Text -> "txt"
+
+let filetype_of_extension = function
+ | "ml" -> Implementation
+ | "mli" -> Interface
+ | "c" -> C
+ | "cmm" -> C_minus_minus
+ | "mll" -> Lexer
+ | "mly" -> Grammar
+ | "cmi" -> Binary_interface
+ | "cmx" -> Backend_specific (Ocaml_backends.Native, Object)
+ | "cmxa" -> Backend_specific (Ocaml_backends.Native, Library)
+ | "opt" -> Backend_specific (Ocaml_backends.Native, Program)
+ | "cmo" -> Backend_specific (Ocaml_backends.Bytecode, Object)
+ | "cma" -> Backend_specific (Ocaml_backends.Bytecode, Library)
+ | "byte" -> Backend_specific (Ocaml_backends.Bytecode, Program)
+ | "txt" -> Text
+ | _ -> raise Not_found
+
+let split_filename name =
+ let l = String.length name in
+ let is_dir_sep name i = name.[i] = Filename.dir_sep.[0] in
+ let rec search_dot i =
+ if i < 0 || is_dir_sep name i then (name, "")
+ else if name.[i] = '.' then
+ let basename = String.sub name 0 i in
+ let extension = String.sub name (i+1) (l-i-1) in
+ (basename, extension)
+ else search_dot (i - 1) in
+ search_dot (l - 1)
+
+let filetype filename =
+ let (basename, extension) = split_filename filename in
+ (basename, filetype_of_extension extension)
+
+let make_filename (basename, filetype) =
+ let extension = extension_of_filetype filetype in
+ basename ^ "." ^ extension
+
+let action_of_filetype = function
+ | Implementation -> "Compiling implementation"
+ | Interface -> "Compiling interface"
+ | C -> "Compiling C source file"
+ | C_minus_minus -> "Processing C-- file"
+ | Lexer -> "Generating lexer"
+ | Grammar -> "Generating parser"
+ | filetype -> ("nothing to do for " ^ (string_of_filetype filetype))
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2016 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Types of files involved in an OCaml project and related functions *)
+
+type backend_specific = Object | Library | Program
+
+type t =
+ | Implementation
+ | Interface
+ | C
+ | C_minus_minus
+ | Lexer
+ | Grammar
+ | Binary_interface
+ | Backend_specific of Ocaml_backends.t * backend_specific
+ | Text (** text-only documentation file *)
+
+val string_of_filetype : t -> string
+
+val extension_of_filetype : t -> string
+
+val filetype_of_extension : string -> t
+
+val split_filename : string -> string * string
+
+val filetype : string -> string * t
+
+val make_filename : string * t -> string
+
+val action_of_filetype : t -> string
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Flags used in OCaml commands *)
+
+let stdlib ocamlsrcdir =
+ let stdlib_path = Ocaml_directories.stdlib ocamlsrcdir in
+ "-nostdlib -I " ^ stdlib_path
+
+let include_toplevel_directory ocamlsrcdir =
+ "-I " ^ (Ocaml_directories.toplevel ocamlsrcdir)
+
+let c_includes ocamlsrcdir =
+ let dir = Ocaml_directories.runtime ocamlsrcdir in
+ "-ccopt -I" ^ dir
+
+let runtime_variant_flags () = match Ocaml_files.runtime_variant() with
+ | Ocaml_files.Normal -> ""
+ | Ocaml_files.Debug -> " -runtime-variant d"
+ | Ocaml_files.Instrumented -> " -runtime-variant i"
+
+let runtime_flags ocamlsrcdir backend c_files =
+ let runtime_library_flags = "-I " ^
+ (Ocaml_directories.runtime_library backend ocamlsrcdir) in
+ let rt_flags = match backend with
+ | Ocaml_backends.Native -> runtime_variant_flags ()
+ | Ocaml_backends.Bytecode ->
+ begin
+ if c_files then begin (* custom mode *)
+ "-custom " ^ (runtime_variant_flags ())
+ end else begin (* non-custom mode *)
+ "-use-runtime " ^ (Ocaml_files.ocamlrun ocamlsrcdir)
+ end
+ end in
+ rt_flags ^ " " ^ runtime_library_flags
+
+let toplevel_default_flags = "-noinit -no-version -noprompt"
+
+let ocamldebug_default_flags ocamlsrcdir =
+ "-no-version -no-prompt -no-time -no-breakpoint-message " ^
+ ("-topdirs-path " ^ (Ocaml_directories.toplevel ocamlsrcdir))
+
+let ocamlobjinfo_default_flags = "-null-crc"
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Flags used in OCaml commands *)
+
+val stdlib : string -> string
+
+val include_toplevel_directory : string -> string
+
+val c_includes : string -> string
+
+val runtime_flags : string -> Ocaml_backends.t -> bool -> string
+
+val toplevel_default_flags : string
+
+val ocamldebug_default_flags : string -> string
+
+val ocamlobjinfo_default_flags : string
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2016 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Definition of a few OCaml-specific environment modifiers *)
+
+open Ocamltest_stdlib
+open Environments
+
+let principal =
+[
+ Append (Ocaml_variables.flags, " -principal ");
+ Add (Ocaml_variables.compiler_directory_suffix, ".principal");
+ Add (Ocaml_variables.compiler_reference_suffix, ".principal");
+]
+
+let latex =
+ [
+ Add (Ocaml_variables.ocamldoc_backend, "latex");
+ Append (Ocaml_variables.ocamldoc_flags, "-latex-type-prefix=TYP ");
+ Append (Ocaml_variables.ocamldoc_flags, "-latex-module-prefix= ");
+ Append (Ocaml_variables.ocamldoc_flags, "-latex-value-prefix= ");
+ Append (Ocaml_variables.ocamldoc_flags, "-latex-module-type-prefix= ");
+ Append (Ocaml_variables.ocamldoc_flags, "-latextitle=1,subsection* ");
+ Append (Ocaml_variables.ocamldoc_flags, "-latextitle=2,subsubsection* ");
+ Append (Ocaml_variables.ocamldoc_flags, "-latextitle=6,subsection* ");
+ Append (Ocaml_variables.ocamldoc_flags, "-latextitle=7,subsubsection* ");
+ ]
+
+
+let html =
+ [
+ Add (Ocaml_variables.ocamldoc_backend, "html");
+ Append (Ocaml_variables.ocamldoc_flags, "-colorize-code ");
+ ]
+
+let man =
+ [
+ Add (Ocaml_variables.ocamldoc_backend, "man");
+ ]
+
+let wrap str = (" " ^ str ^ " ")
+
+let make_library_modifier library directory =
+[
+ Append (Ocaml_variables.directories, (wrap directory));
+ Append (Ocaml_variables.libraries, (wrap library));
+ Append (Ocaml_variables.caml_ld_library_path, (wrap directory));
+]
+
+let make_module_modifier unit_name directory =
+[
+ Append (Ocaml_variables.directories, (wrap directory));
+ Append (Ocaml_variables.binary_modules, (wrap unit_name));
+]
+
+let compiler_subdir subdir =
+ Filename.make_path (Ocamltest_config.ocamlsrcdir :: subdir)
+
+let config =
+[
+ Append (Ocaml_variables.directories, (wrap (compiler_subdir ["utils"])));
+]
+
+let testing = make_library_modifier
+ "testing" (compiler_subdir ["testsuite"; "lib"])
+
+let tool_ocaml_lib = make_module_modifier
+ "lib" (compiler_subdir ["testsuite"; "lib"])
+
+let unixlibdir = if Sys.os_type="Win32" then "win32unix" else "unix"
+
+let unix = make_library_modifier
+ "unix" (compiler_subdir ["otherlibs"; unixlibdir])
+
+let str = make_library_modifier
+ "str" (compiler_subdir ["otherlibs"; "str"])
+
+let systhreads =
+ unix @
+ (make_library_modifier
+ "threads" (compiler_subdir ["otherlibs"; "systhreads"]))
+
+let compilerlibs_subdirs =
+[
+ "utils"; "parsing"; "toplevel"; "typing"; "bytecomp"; "compilerlibs";
+]
+
+let add_compiler_subdir subdir =
+ Append (Ocaml_variables.directories, (wrap (compiler_subdir [subdir])))
+
+let ocamlcommon =
+ (Append (Ocaml_variables.libraries, wrap "ocamlcommon")) ::
+ (List.map add_compiler_subdir compilerlibs_subdirs)
+
+let _ =
+ register_modifiers "principal" principal;
+ register_modifiers "config" config;
+ register_modifiers "testing" testing;
+ register_modifiers "unix" unix;
+ register_modifiers "str" str;
+ register_modifiers "ocamlcommon" ocamlcommon;
+ register_modifiers "systhreads" systhreads;
+ register_modifiers "latex" latex;
+ register_modifiers "html" html;
+ register_modifiers "man" man;
+ register_modifiers "tool-ocaml-lib" tool_ocaml_lib;
+ ()
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2016 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Definition of a few OCaml-specific environment modifiers *)
+
+val principal : Environments.modifiers
+
+val testing : Environments.modifiers
+
+val unix : Environments.modifiers
+
+val str : Environments.modifiers
+
+val latex: Environments.modifiers
+val man: Environments.modifiers
+val html: Environments.modifiers
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2016 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Tests specific to the OCaml compiler *)
+
+open Tests
+open Builtin_actions
+open Ocaml_actions
+
+let bytecode =
+ let opt_actions =
+ [
+ setup_ocamlc_opt_build_env;
+ ocamlc_opt;
+ check_ocamlc_opt_output;
+ compare_bytecode_programs
+ ] in
+{
+ test_name = "bytecode";
+ test_run_by_default = true;
+ test_actions =
+ [
+ setup_ocamlc_byte_build_env;
+ ocamlc_byte;
+ check_ocamlc_byte_output;
+ run;
+ check_program_output;
+ ] @ (if Ocamltest_config.arch<>"none" then opt_actions else [])
+}
+
+let native =
+ let opt_actions =
+ [
+ setup_ocamlopt_byte_build_env;
+ ocamlopt_byte;
+ check_ocamlopt_byte_output;
+ run;
+ check_program_output;
+ setup_ocamlopt_opt_build_env;
+ ocamlopt_opt;
+ check_ocamlopt_opt_output;
+ compare_native_programs;
+ ] in
+ {
+ test_name = "native";
+ test_run_by_default = true;
+ test_actions =
+ (if Ocamltest_config.arch<>"none" then opt_actions else [skip])
+ }
+
+let toplevel = {
+ test_name = "toplevel";
+ test_run_by_default = false;
+ test_actions =
+ [
+ setup_ocaml_build_env;
+ ocaml;
+ check_ocaml_output;
+(*
+ setup_ocamlnat_build_env;
+ ocamlnat;
+ check_ocamlnat_output;
+*)
+ ]
+}
+
+let expect =
+{
+ test_name = "expect";
+ test_run_by_default = false;
+ test_actions =
+ [
+ setup_simple_build_env;
+ run_expect;
+ check_program_output
+ ]
+}
+
+let ocamldoc =
+{
+ test_name = "ocamldoc";
+ test_run_by_default = false;
+ test_actions =
+ if Ocamltest_config.ocamldoc then
+ [
+ shared_libraries;
+ setup_ocamldoc_build_env;
+ run_ocamldoc;
+ check_program_output;
+ check_ocamldoc_output
+ ]
+ else
+ [ skip ]
+}
+
+let _ =
+ List.iter register
+ [
+ bytecode;
+ native;
+ toplevel;
+ expect;
+ ocamldoc;
+ ]
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2016 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Tests specific to the OCaml compiler *)
+
+val bytecode : Tests.t
+
+val native : Tests.t
+
+val toplevel : Tests.t
+
+val expect : Tests.t
+
+val ocamldoc : Tests.t
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Descriptions of the OCaml tools *)
+
+open Ocamltest_stdlib
+
+class tool
+ ~(name : string -> string)
+ ~(family : string)
+ ~(flags : string)
+ ~(directory : string)
+ ~(exit_status_variable : Variables.t)
+ ~(reference_variable : Variables.t)
+ ~(output_variable : Variables.t)
+= object (self)
+ method name = name
+ method family = family
+ method flags = flags
+ method directory = directory
+ method exit_status_variable = exit_status_variable
+ method reference_variable = reference_variable
+ method output_variable = output_variable
+
+ method reference_filename_suffix env =
+ let tool_reference_suffix =
+ Environments.safe_lookup Ocaml_variables.compiler_reference_suffix env
+ in
+ if tool_reference_suffix<>""
+ then tool_reference_suffix ^ ".reference"
+ else ".reference"
+
+ method reference_file env prefix =
+ let suffix = self#reference_filename_suffix env in
+ (Filename.make_filename prefix directory) ^ suffix
+end
+
+let expected_exit_status env tool =
+ Actions_helpers.exit_status_of_variable env tool#exit_status_variable
+
+
+let ocamldoc =
+ object inherit
+ tool
+ ~name:Ocaml_files.ocamldoc
+ ~family:"doc"
+ ~flags:""
+ ~directory:"ocamldoc"
+ ~exit_status_variable:Ocaml_variables.ocamldoc_exit_status
+ ~reference_variable:Ocaml_variables.ocamldoc_reference
+ ~output_variable:Ocaml_variables.ocamldoc_output
+
+ method ! reference_filename_suffix env =
+ let backend =
+ Environments.safe_lookup Ocaml_variables.ocamldoc_backend env in
+ if backend = "" then
+ ".reference"
+ else "." ^ backend ^ ".reference"
+ end
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Descriptions of the OCaml tools *)
+
+class tool :
+ name : (string -> string) ->
+ family : string ->
+ flags : string ->
+ directory : string ->
+ exit_status_variable : Variables.t ->
+ reference_variable : Variables.t ->
+ output_variable : Variables.t ->
+object
+ method name : string -> string
+ method family : string
+ method flags : string
+ method directory : string
+ method exit_status_variable : Variables.t
+ method reference_variable : Variables.t
+ method output_variable : Variables.t
+ method reference_filename_suffix : Environments.t -> string
+ method reference_file : Environments.t -> string -> string
+end
+
+val expected_exit_status : Environments.t -> tool -> int
+
+val ocamldoc: tool
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Description of the OCaml toplevels *)
+
+open Ocamltest_stdlib
+
+class toplevel
+ ~(name : string -> string)
+ ~(flags : string)
+ ~(directory : string)
+ ~(exit_status_variable : Variables.t)
+ ~(reference_variable : Variables.t)
+ ~(output_variable : Variables.t)
+ ~(backend : Ocaml_backends.t)
+ ~(compiler : Ocaml_compilers.compiler)
+= object (self) inherit Ocaml_tools.tool
+ ~name:name
+ ~family:"toplevel"
+ ~flags:flags
+ ~directory:directory
+ ~exit_status_variable:exit_status_variable
+ ~reference_variable:reference_variable
+ ~output_variable:output_variable
+ as tool
+ method backend = backend
+ method compiler = compiler
+ method ! reference_file env prefix =
+ let default = tool#reference_file env prefix in
+ if Sys.file_exists default then default else
+ let suffix = self#reference_filename_suffix env in
+ let mk s = (Filename.make_filename prefix s) ^ suffix in
+ let filename = mk
+ (Ocaml_backends.string_of_backend self#backend) in
+ if Sys.file_exists filename then filename else
+ mk "compilers"
+
+end
+
+let ocaml = new toplevel
+ ~name: Ocaml_commands.ocamlrun_ocaml
+ ~flags: ""
+ ~directory: "ocaml"
+ ~exit_status_variable: Ocaml_variables.ocaml_exit_status
+ ~reference_variable: Ocaml_variables.compiler_reference
+ ~output_variable: Ocaml_variables.compiler_output
+ ~backend: Ocaml_backends.Bytecode
+ ~compiler: Ocaml_compilers.ocamlc_byte
+
+let ocamlnat = new toplevel
+ ~name: Ocaml_files.ocamlnat
+ ~flags: "-S" (* Keep intermediate assembly files *)
+ ~directory: "ocamlnat"
+ ~exit_status_variable: Ocaml_variables.ocamlnat_exit_status
+ ~reference_variable: Ocaml_variables.compiler_reference2
+ ~output_variable: Ocaml_variables.compiler_output2
+ ~backend: Ocaml_backends.Native
+ ~compiler: Ocaml_compilers.ocamlc_opt
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Descriptions of the OCaml toplevels *)
+
+class toplevel :
+ name : (string -> string) ->
+ flags : string ->
+ directory : string ->
+ exit_status_variable : Variables.t ->
+ reference_variable : Variables.t ->
+ output_variable : Variables.t ->
+ backend : Ocaml_backends.t ->
+ compiler : Ocaml_compilers.compiler ->
+object inherit Ocaml_tools.tool
+ method backend : Ocaml_backends.t
+ method compiler : Ocaml_compilers.compiler
+end
+
+val ocaml : toplevel
+
+val ocamlnat : toplevel
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2016 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Definition of variables used by built-in actions *)
+
+(* The variables are listed in alphabetical order *)
+
+(*
+ The name of the identifier representing a variable and its string name
+ should be similar. Is there a way to enforce this?
+*)
+
+open Ocamltest_stdlib
+
+open Variables (* Should not be necessary with a ppx *)
+
+let all_modules = make ("all_modules",
+ "All the modules to compile and link")
+
+let binary_modules = make ("binary_modules",
+ "Additional binary modules to link")
+
+let c_preprocessor = make ("c_preprocessor",
+ "Command to use to invoke the C preprocessor")
+
+let caml_ld_library_path_name = "CAML_LD_LIBRARY_PATH"
+
+let export_caml_ld_library_path value =
+ let current_value = Sys.safe_getenv caml_ld_library_path_name in
+ let local_value =
+ (String.concat Filename.path_sep (String.words value)) in
+ let new_value =
+ if local_value="" then current_value else
+ if current_value="" then local_value else
+ String.concat Filename.path_sep [local_value; current_value] in
+ Printf.sprintf "%s=%s" caml_ld_library_path_name new_value
+
+let caml_ld_library_path =
+ make_with_exporter
+ export_caml_ld_library_path
+ ("ld_library_path",
+ "List of paths to lookup for loading dynamic libraries")
+
+let compare_programs = make ("compare_programs",
+ "Set to \"false\" to disable program comparison")
+
+let compiler_directory_suffix = make ("compiler_directory_suffix",
+ "Suffix to add to the directory where the test will be compiled")
+
+let compiler_reference = make ("compiler_reference",
+ "Reference file for compiler output for ocamlc.byte and ocamlopt.byte")
+
+let compiler_reference2 = make ("compiler_reference2",
+ "Reference file for compiler output for ocamlc.opt and ocamlopt.opt")
+
+let compiler_reference_suffix = make ("compiler_reference_suffix",
+ "Suffix to add to the file name containing the reference for compiler output")
+
+let compiler_output = make ("compiler_output",
+ "Where to log output of bytecode compilers")
+
+let compiler_output2 = make ("compiler_output2",
+ "Where to log output of native compilers")
+
+let compiler_stdin = make ("compiler_stdin",
+ "standard input of compilers")
+
+let compile_only = make ("compile_only",
+ "Compile only (do not link)")
+
+let ocamlc_flags = make ("ocamlc_flags",
+ "Flags passed to ocamlc.byte and ocamlc.opt")
+
+let ocamlc_default_flags = make ("ocamlc_default_flags",
+ "Flags passed by default to ocamlc.byte and ocamlc.opt")
+
+let directories = make ("directories",
+ "Directories to include by all the compilers")
+
+let flags = make ("flags",
+ "Flags passed to all the compilers")
+
+let libraries = make ("libraries",
+ "Libraries the program should be linked with")
+
+let module_ = make ("module",
+ "Compile one module at once")
+
+let modules = make ("modules",
+ "Other modules of the test")
+
+let ocamllex_flags = make ("ocamllex_flags",
+ "Flags passed to ocamllex")
+
+let ocamlopt_flags = make ("ocamlopt_flags",
+ "Flags passed to ocamlopt.byte and ocamlopt.opt")
+
+let ocamlopt_default_flags = make ("ocamlopt_default_flags",
+ "Flags passed by default to ocamlopt.byte and ocamlopt.opt")
+
+let ocamlyacc_flags = make ("ocamlyacc_flags",
+ "Flags passed to ocamlyacc")
+
+let ocaml_exit_status = make ("ocaml_exit_status",
+ "Expected exit status of ocaml")
+
+let ocamlc_byte_exit_status = make ("ocamlc_byte_exit_status",
+ "Expected exit status of ocac.byte")
+
+let ocamlopt_byte_exit_status = make ("ocamlopt_byte_exit_status",
+ "Expected exit status of ocamlopt.byte")
+
+let ocamlnat_exit_status = make ("ocamlnat_exit_status",
+ "Expected exit status of ocamlnat")
+
+let ocamlc_opt_exit_status = make ("ocamlc_opt_exit_status",
+ "Expected exit status of ocac.opt")
+
+let ocamlopt_opt_exit_status = make ("ocamlopt_opt_exit_status",
+ "Expected exit status of ocamlopt.opt")
+
+let export_ocamlrunparam value =
+ Printf.sprintf "%s=%s" "OCAMLRUNPARAM" value
+
+let ocamlrunparam =
+ make_with_exporter
+ export_ocamlrunparam
+ ("ocamlrunparam",
+ "Equivalent of OCAMLRUNPARAM")
+
+let ocamlsrcdir = make ("ocamlsrcdir",
+ "Where OCaml sources are")
+
+let ocamldebug_flags = make ("ocamldebug_flags",
+ "Flags for ocamldebug")
+
+let ocamldebug_script = make ("ocamldebug_script",
+ "Where ocamldebug should read its commands")
+
+let os_type = make ("os_type",
+ "The OS we are running on")
+
+let ocamldoc_flags = Variables.make ("ocamldoc_flags",
+ "ocamldoc flags")
+
+let ocamldoc_backend = Variables.make ("ocamldoc_backend",
+ "ocamldoc backend (html, latex, man, ... )")
+
+let ocamldoc_exit_status =
+ Variables.make ( "ocamldoc_exit_status", "expected ocamldoc exit status")
+
+let ocamldoc_output =
+ Variables.make ( "ocamldoc_output", "Where to log ocamldoc output")
+
+let ocamldoc_reference =
+ Variables.make ( "ocamldoc_reference",
+ "Where to find expected ocamldoc output")
+
+let ocaml_script_as_argument =
+ Variables.make ( "ocaml_script_as_argument",
+ "Whether the ocaml script should be passed as argument or on stdin")
+
+let plugins =
+ Variables.make ( "plugins", "plugins for ocamlc,ocamlopt or ocamldoc" )
+
+let _ = List.iter register_variable
+ [
+ all_modules;
+ binary_modules;
+ c_preprocessor;
+ caml_ld_library_path;
+ compare_programs;
+ compiler_directory_suffix;
+ compiler_reference;
+ compiler_reference2;
+ compiler_reference_suffix;
+ compiler_output;
+ compiler_output2;
+ compiler_stdin;
+ compile_only;
+ directories;
+ flags;
+ libraries;
+ module_;
+ modules;
+ ocamlc_flags;
+ ocamlc_default_flags;
+ ocamlopt_flags;
+ ocamlopt_default_flags;
+ ocaml_exit_status;
+ ocamlc_byte_exit_status;
+ ocamlopt_byte_exit_status;
+ ocamlnat_exit_status;
+ ocamlc_opt_exit_status;
+ ocamlopt_opt_exit_status;
+ ocamlrunparam;
+ os_type;
+ ocamllex_flags;
+ ocamlyacc_flags;
+ ocamldoc_flags;
+ ocamldoc_backend;
+ ocamldoc_output;
+ ocamldoc_reference;
+ ocamldoc_exit_status;
+ ocamldebug_flags;
+ ocamldebug_script;
+ ocaml_script_as_argument;
+ plugins
+ ]
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2016 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Definition of OCaml-specific variables *)
+
+(* The variables are listed in alphabetical order *)
+
+val all_modules : Variables.t
+
+val binary_modules : Variables.t
+
+val c_preprocessor : Variables.t
+
+val caml_ld_library_path : Variables.t
+
+val compare_programs : Variables.t
+
+val compiler_directory_suffix : Variables.t
+
+val compiler_reference : Variables.t
+
+val compiler_reference2 : Variables.t
+
+val compiler_reference_suffix : Variables.t
+
+val compiler_output : Variables.t
+
+val compiler_output2 : Variables.t
+
+val compiler_stdin : Variables.t
+
+val compile_only : Variables.t
+
+val directories : Variables.t
+
+val flags : Variables.t
+
+val libraries : Variables.t
+
+val module_ : Variables.t
+
+val modules : Variables.t
+
+val ocamlc_flags : Variables.t
+val ocamlc_default_flags : Variables.t
+
+val ocamllex_flags : Variables.t
+
+val ocamlopt_flags : Variables.t
+val ocamlopt_default_flags : Variables.t
+
+val ocamlyacc_flags : Variables.t
+
+val ocaml_exit_status : Variables.t
+
+val ocamlc_byte_exit_status : Variables.t
+
+val ocamlopt_byte_exit_status : Variables.t
+
+val ocamlnat_exit_status : Variables.t
+
+val ocamlc_opt_exit_status : Variables.t
+
+val ocamlopt_opt_exit_status : Variables.t
+
+val ocamlrunparam : Variables.t
+
+val ocamlsrcdir : Variables.t
+
+val ocamldebug_flags : Variables.t
+
+val ocamldebug_script : Variables.t
+
+val os_type : Variables.t
+
+val ocamldoc_flags : Variables.t
+val ocamldoc_backend : Variables.t
+val ocamldoc_exit_status : Variables.t
+val ocamldoc_output : Variables.t
+val ocamldoc_reference : Variables.t
+
+val ocaml_script_as_argument : Variables.t
+
+val plugins: Variables.t
let arch = "@@ARCH@@"
+let afl_instrument = @@AFL_INSTRUMENT@@
+
+let shared_libraries = @@SHARED_LIBRARIES@@
+
+let libunix = @@UNIX@@
+
+let system = "@@SYSTEM@@"
+
let c_preprocessor = "@@CPP@@"
let ocamlsrcdir = "@@OCAMLSRCDIR@@"
let flambda = @@FLAMBDA@@
+let spacetime = @@SPACETIME@@
+
let ocamlc_default_flags = "@@OCAMLCDEFAULTFLAGS@@"
let ocamlopt_default_flags = "@@OCAMLOPTDEFAULTFLAGS@@"
let safe_string = @@FORCE_SAFE_STRING@@
+
+let flat_float_array = @@FLAT_FLOAT_ARRAY@@
+
+let ocamldoc = @@OCAMLDOC@@
+
+let ocamldebug = @@OCAMLDOC@@
val arch : string
(** Architecture for the native compiler, "none" if it is disabled *)
+val afl_instrument : bool
+(** Whether AFL support has been enabled in the compiler *)
+
+val shared_libraries : bool
+(** [true] if shared libraries are supported, [false] otherwise *)
+
+val libunix : bool
+(** [true] for unix, [false] for win32unix *)
+
+val system : string
+(** The content of the SYSTEM Make variable *)
+
val c_preprocessor : string
(** Command to use to invoke the C preprocessor *)
-
val ocamlc_default_flags : string
(** Flags passed by default to ocamlc.byte and ocamlc.opt *)
val flambda : bool
(** Whether flambda has been enabled at configure time *)
+val spacetime : bool
+(** Whether Spacetime profiling has been enabled at configure time *)
+
val safe_string : bool
(** Whether the compiler was configured with -safe-string *)
+
+val flat_float_array : bool
+(* Whether the compiler was configured with -flat-float-array *)
+
+val ocamldoc : bool
+(** Whether ocamldoc has been enabled at configure time *)
+
+val ocamldebug : bool
+(** Whether ocamldebug has been enabled at configure time *)
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2016 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* A few extensions to OCaml's standard library *)
+
+(* Pervaisive *)
+
+let input_line_opt ic =
+ try Some (input_line ic) with End_of_file -> None
+
+module Char = struct
+ include Char
+ let is_blank c =
+ c = ' ' || c = '\012' || c = '\n' || c = '\r' || c = '\t'
+end
+
+module Filename = struct
+ include Filename
+ let path_sep = if Sys.os_type="Win32" then ";" else ":"
+ (* This function comes from otherlibs/win32unix/unix.ml *)
+ let maybe_quote f =
+ if String.contains f ' ' ||
+ String.contains f '\"' ||
+ String.contains f '\t' ||
+ f = ""
+ then Filename.quote f
+ else f
+
+ let make_filename name ext = String.concat "." [name; ext]
+
+ let make_path components = List.fold_left Filename.concat "" components
+
+ let mkexe =
+ if Sys.os_type="Win32"
+ then fun name -> make_filename name "exe"
+ else fun name -> name
+end
+
+module List = struct
+ include List
+ let rec concatmap f = function
+ | [] -> []
+ | x::xs -> (f x) @ (concatmap f xs)
+end
+
+module String = struct
+ include String
+ let string_of_char = String.make 1
+
+ let words s =
+ let l = String.length s in
+ let rec f quote w ws i =
+ if i>=l then begin
+ if w<>"" then List.rev (w::ws)
+ else List.rev ws
+ end else begin
+ let j = i+1 in
+ match s.[i] with
+ | '\'' -> f (not quote) w ws j
+ | ' ' ->
+ begin
+ if quote
+ then f true (w ^ (string_of_char ' ')) ws j
+ else begin
+ if w=""
+ then f false w ws j
+ else f false "" (w::ws) j
+ end
+ end
+ | _ as c -> f quote (w ^ (string_of_char c)) ws j
+ end in
+ if l=0 then [] else f false "" [] 0
+end
+
+module Sys = struct
+ include Sys
+
+ let file_is_empty filename =
+ let ic = open_in filename in
+ let filesize = in_channel_length ic in
+ close_in ic;
+ filesize = 0
+
+ let run_system_command command = match Sys.command command with
+ | 0 -> ()
+ | _ as exitcode ->
+ Printf.eprintf "Sysem command %s failed with status %d\n%!"
+ command exitcode;
+ exit 3
+
+ let mkdir dir =
+ if not (Sys.file_exists dir) then
+ let quoted_dir = "\"" ^ dir ^ "\"" in
+ run_system_command ("mkdir " ^ quoted_dir)
+
+ let rec make_directory dir =
+ if Sys.file_exists dir then ()
+ else (make_directory (Filename.dirname dir); mkdir dir)
+
+ let string_of_file filename =
+ let chan = open_in_bin filename in
+ let filesize = in_channel_length chan in
+ if filesize > Sys.max_string_length then
+ begin
+ close_in chan;
+ failwith
+ ("The file " ^ filename ^ " is too large to be loaded into a string")
+ end else begin
+ let result =
+ try really_input_string chan filesize
+ with End_of_file ->
+ close_in chan;
+ failwith ("Got unexpected end of file while reading " ^ filename) in
+ close_in chan;
+ result
+ end
+
+ let with_input_file ?(bin=false) x f =
+ let ic = (if bin then open_in_bin else open_in) x in
+ try let res = f ic in close_in ic; res with e -> (close_in ic; raise e)
+
+ let with_output_file ?(bin=false) x f =
+ let oc = (if bin then open_out_bin else open_out) x in
+ try let res = f oc in close_out oc; res with e -> (close_out oc; raise e)
+
+ let copy_chan ic oc =
+ let m = in_channel_length ic in
+ let m = (m lsr 12) lsl 12 in
+ let m = max 16384 (min Sys.max_string_length m) in
+ let buf = Bytes.create m in
+ let rec loop () =
+ let len = input ic buf 0 m in
+ if len > 0 then begin
+ output oc buf 0 len;
+ loop ()
+ end
+ in loop ()
+
+ let copy_file src dest =
+ with_input_file ~bin:true src begin fun ic ->
+ with_output_file ~bin:true dest begin fun oc ->
+ copy_chan ic oc
+ end
+ end
+
+ let force_remove file =
+ if file_exists file then remove file
+
+ external has_symlink : unit -> bool = "caml_has_symlink"
+
+ let with_chdir path f =
+ let oldcwd = Sys.getcwd () in
+ Sys.chdir path;
+ match f () with
+ | r ->
+ Sys.chdir oldcwd;
+ r
+ | exception e ->
+ Sys.chdir oldcwd;
+ raise e
+
+ let getenv_with_default_value variable default_value =
+ try Sys.getenv variable with Not_found -> default_value
+ let safe_getenv variable = getenv_with_default_value variable ""
+end
+
+module StringSet = struct
+ include Set.Make (String)
+ let string_of_stringset s = String.concat ", " (elements s)
+end
+
+module StringMap : Map.S with type key = string = Map.Make (String)
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2016 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* A few extensions to OCaml's standard library *)
+
+(* Pervasive *)
+
+val input_line_opt : in_channel -> string option
+
+module Char : sig
+ include module type of Char
+ val is_blank : char -> bool
+end
+
+module Filename : sig
+ include module type of Filename
+ val path_sep : string
+ val maybe_quote : string -> string
+ val make_filename : string -> string -> string
+ val make_path : string list -> string
+ val mkexe : string -> string
+end
+
+module List : sig
+ include module type of List
+ val concatmap : ('a -> 'b list) -> 'a list -> 'b list
+end
+
+module String : sig
+ include module type of String
+ val words : string -> string list
+end
+
+module Sys : sig
+ include module type of Sys
+ val file_is_empty : string -> bool
+ val run_system_command : string -> unit
+ val make_directory : string -> unit
+ val string_of_file : string -> string
+ val copy_file : string -> string -> unit
+ val force_remove : string -> unit
+ val has_symlink : unit -> bool
+ val with_chdir : string -> (unit -> 'a) -> 'a
+ val getenv_with_default_value : string -> string -> string
+ val safe_getenv : string -> string
+end
+
+module StringSet : sig
+ include Set.S with type elt = string
+ val string_of_stringset : t -> string
+end
+
+module StringMap : Map.S with type key = string
--- /dev/null
+/**************************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Sebastien Hinderer, projet Gallium, INRIA Paris */
+/* */
+/* Copyright 2018 Institut National de Recherche en Informatique et */
+/* en Automatique. */
+/* */
+/* All rights reserved. This file is distributed under the terms of */
+/* the GNU Lesser General Public License version 2.1, with the */
+/* special exception on linking described in the file LICENSE. */
+/* */
+/**************************************************************************/
+
+/* Stubs for ocamltest's standard library */
+
+#include <stdio.h>
+#include <stdlib.h>
+
+#include <caml/config.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+/*
+#include <caml/fail.h>
+*/
+#include <caml/signals.h>
+#include <caml/osdeps.h>
+
+
+#ifdef _WIN32
+
+/*
+ * Windows Vista functions enabled
+ */
+#undef _WIN32_WINNT
+#define _WIN32_WINNT 0x0600
+
+#include <wtypes.h>
+#include <winbase.h>
+#include <process.h>
+#include <sys/types.h>
+
+#define luid_eq(l, r) (l.LowPart == r.LowPart && l.HighPart == r.HighPart)
+
+CAMLprim value caml_has_symlink(value unit)
+{
+ CAMLparam1(unit);
+ HANDLE hProcess = GetCurrentProcess();
+ BOOL result = FALSE;
+
+ if (OpenProcessToken(hProcess, TOKEN_READ, &hProcess)) {
+ LUID seCreateSymbolicLinkPrivilege;
+
+ if (LookupPrivilegeValue(NULL,
+ SE_CREATE_SYMBOLIC_LINK_NAME,
+ &seCreateSymbolicLinkPrivilege)) {
+ DWORD length;
+
+ if (!GetTokenInformation(hProcess, TokenPrivileges, NULL, 0, &length)) {
+ if (GetLastError() == ERROR_INSUFFICIENT_BUFFER) {
+ TOKEN_PRIVILEGES* privileges = (TOKEN_PRIVILEGES*)caml_stat_alloc(length);
+ if (GetTokenInformation(hProcess,
+ TokenPrivileges,
+ privileges,
+ length,
+ &length)) {
+ DWORD count = privileges->PrivilegeCount;
+
+ if (count) {
+ LUID_AND_ATTRIBUTES* privs = privileges->Privileges;
+ while (count-- && !(result = luid_eq(privs->Luid, seCreateSymbolicLinkPrivilege)))
+ privs++;
+ }
+ }
+
+ caml_stat_free(privileges);
+ }
+ }
+ }
+
+ CloseHandle(hProcess);
+ }
+
+ CAMLreturn(Val_bool(result));
+}
+
+
+#else /* _WIN32 */
+
+#ifdef HAS_SYMLINK
+
+CAMLprim value caml_has_symlink(value unit)
+{
+ CAMLparam0();
+ CAMLreturn(Val_true);
+}
+
+#else /* HAS_SYMLINK */
+
+CAMLprim value unix_symlink(value to_dir, value path1, value path2)
+{ caml_invalid_argument("symlink not implemented"); }
+
+CAMLprim value caml_has_symlink(value unit)
+{
+ CAMLparam0();
+ CAMLreturn(Val_false);
+}
+
+#endif
+
+#endif /* _WIN32 */
List.iter print_object objects;
exit 0
-let string_of_action action = action.Actions.action_name
+let string_of_action = Actions.action_name
let string_of_test test =
if test.Tests.test_run_by_default
let tests = Tests.get_registered_tests () in
show_objects "Available tests are:" string_of_test tests
+let log_to_stderr = ref false
+
+let promote = ref false
+
let commandline_options =
[
+ ("-e", Arg.Set log_to_stderr, "Log to stderr instead of a file.");
+ ("-promote", Arg.Set promote,
+ "Overwrite reference files with the test output (experimental, unstable)");
("-show-actions", Arg.Unit show_actions, "Show available actions.");
("-show-tests", Arg.Unit show_tests, "Show available tests.");
]
-let testfile = ref ""
+let files_to_test = ref []
-let set_testfile name =
- if !testfile<> "" then
- begin
- Printf.eprintf "Can't deal with more than one test file at the moment\n%!";
- exit 1
- end else testfile := name
+let add_testfile name = files_to_test := !files_to_test @ [name]
-let usage = "Usage: " ^ Sys.argv.(0) ^ " options testfile"
+let usage = "Usage: " ^ Sys.argv.(0) ^ " options files to test"
let _ =
- Arg.parse commandline_options set_testfile usage
+ Arg.parse commandline_options add_testfile usage
(* Description of ocamltest's command-line options *)
-val testfile : string ref
+val log_to_stderr : bool ref
+
+val files_to_test : string list ref
+
+val promote : bool ref
val usage : string
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Definition of test-result related types and functions *)
+
+type status = Pass | Skip | Fail
+
+type t = {
+ status : status;
+ reason : string option
+}
+
+let result_of_status s = { status = s; reason = None }
+
+let pass = result_of_status Pass
+
+let skip = result_of_status Skip
+
+let fail = result_of_status Fail
+
+let result_with_reason s r = { status = s; reason = Some r }
+
+let pass_with_reason r = result_with_reason Pass r
+
+let skip_with_reason r = result_with_reason Skip r
+
+let fail_with_reason r = result_with_reason Fail r
+
+let string_of_status = function
+ | Pass -> "passed"
+ | Skip -> "skipped"
+ | Fail -> "failed"
+
+let string_of_reason = function
+ | None -> ""
+ | Some reason -> (" (" ^ reason ^ ")")
+
+let string_of_result r =
+ (string_of_status r.status) ^ (string_of_reason r.reason)
+
+let is_pass r = r.status = Pass
+
+let is_skip r = r.status = Skip
+
+let is_fail r = r.status = Fail
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Definition of test-result related types and functions *)
+
+type status = Pass | Skip | Fail
+
+type t = {
+ status : status;
+ reason : string option
+}
+
+val pass : t
+
+val skip : t
+
+val fail : t
+
+val pass_with_reason : string -> t
+
+val skip_with_reason : string -> t
+
+val fail_with_reason : string -> t
+
+val string_of_result : t -> string
+
+val is_pass : t -> bool
+
+val is_skip : t -> bool
+
+val is_fail : t -> bool
typedef struct {
char_os *program;
array argv;
- /* array envp; */
+ array envp;
char_os *stdin_filename;
char_os *stdout_filename;
char_os *stderr_filename;
(* Run programs and log their stdout/stderr, with a timer... *)
+open Ocamltest_stdlib
+
type settings = {
progname : string;
argv : string array;
- (* envp : string array; *)
+ envp : string array;
stdin_filename : string;
stdout_filename : string;
stderr_filename : string;
}
let settings_of_commandline ?(stdout_fname="") ?(stderr_fname="") commandline =
- let words = Testlib.words commandline in
+ let words = String.words commandline in
let quoted_words =
if Sys.os_type="Win32"
- then List.map Testlib.maybe_quote words
+ then List.map Filename.maybe_quote words
else words in
{
progname = List.hd quoted_words;
argv = Array.of_list quoted_words;
+ envp = [||];
stdin_filename = "";
stdout_filename = stdout_fname;
stderr_filename = stderr_fname;
type settings = {
progname : string;
argv : string array;
- (* envp : string array; *)
+ envp : string array;
stdin_filename : string;
stdout_filename : string;
stderr_filename : string;
command_settings settings;
CAMLparam1(caml_settings);
- settings.program = caml_stat_strdup_to_os(String_val(Field(caml_settings, 0)));
+ settings.program =
+ caml_stat_strdup_to_os(String_val(Field(caml_settings, 0)));
settings.argv = cstringvect(Field(caml_settings, 1));
- /* settings.envp = cstringvect(Field(caml_settings, 2)); */
- settings.stdin_filename = caml_stat_strdup_to_os(String_val(Field(caml_settings, 2)));
- settings.stdout_filename = caml_stat_strdup_to_os(String_val(Field(caml_settings, 4)));
- settings.stderr_filename = caml_stat_strdup_to_os(String_val(Field(caml_settings, 4)));
- settings.append = Bool_val(Field(caml_settings, 5));
- settings.timeout = Int_val(Field(caml_settings, 6));
+ settings.envp = cstringvect(Field(caml_settings, 2));
+ settings.stdin_filename =
+ caml_stat_strdup_to_os(String_val(Field(caml_settings, 3)));
+ settings.stdout_filename =
+ caml_stat_strdup_to_os(String_val(Field(caml_settings, 4)));
+ settings.stderr_filename =
+ caml_stat_strdup_to_os(String_val(Field(caml_settings, 5)));
+ settings.append = Bool_val(Field(caml_settings, 6));
+ settings.timeout = Int_val(Field(caml_settings, 7));
settings.logger = logToChannel;
- settings.loggerData = Channel(Field(caml_settings, 7));
+ settings.loggerData = Channel(Field(caml_settings, 8));
res = run_command(&settings);
caml_stat_free(settings.program);
free_cstringvect(settings.argv);
+ free_cstringvect(settings.envp);
caml_stat_free(settings.stdin_filename);
caml_stat_free(settings.stdout_filename);
caml_stat_free(settings.stderr_filename);
/* Same remark as for the error macro. */
+#define child_error(msg, ...) \
+ myperror(msg, ## __VA_ARGS__); \
+ goto child_failed;
+
static void open_error_with_location(
const char *file, int line,
const command_settings *settings,
return same_file;
}
+static void update_environment(array local_env)
+{
+ array envp;
+ for (envp = local_env; *envp != NULL; envp++) {
+ char *pos_eq = strchr(*envp, '=');
+ if (pos_eq != NULL) {
+ char *name, *value;
+ int name_length = pos_eq - *envp;
+ int l = strlen(*envp);
+ int value_length = l - (name_length +1);
+ name = malloc(name_length+1);
+ value = malloc(value_length+1);
+ memcpy(name, *envp, name_length);
+ name[name_length] = '\0';
+ memcpy(value, pos_eq + 1, value_length);
+ value[value_length] = '\0';
+ setenv(name, value, 1); /* 1 means overwrite */
+ }
+ }
+}
+
+/*
+ This function should retunr an exitcode that can itslef be returned
+ to its father through the exit system call.
+ So it returns 0 to report success and 1 to report an error
+
+ */
static int run_command_child(const command_settings *settings)
{
- int res;
int stdin_fd = -1, stdout_fd = -1, stderr_fd = -1; /* -1 = no redir */
int inputFlags = O_RDONLY;
int outputFlags =
O_CREAT | O_WRONLY | (settings->append ? O_APPEND : O_TRUNC);
int inputMode = 0400, outputMode = 0666;
- if (setpgid(0, 0) == -1) myperror("setpgid");
+ if (setpgid(0, 0) == -1)
+ {
+ child_error("setpgid");
+ }
if (is_defined(settings->stdin_filename))
{
stdin_fd = open(settings->stdin_filename, inputFlags, inputMode);
if (stdin_fd < 0)
+ {
open_error(settings->stdin_filename);
- if ( dup2(stdin_fd, STDIN_FILENO) == -1 )
- myperror("dup2 for stdin");
+ goto child_failed;
+ }
+ if (dup2(stdin_fd, STDIN_FILENO) == -1)
+ {
+ child_error("dup2 for stdin");
+ }
}
if (is_defined(settings->stdout_filename))
{
stdout_fd = open(settings->stdout_filename, outputFlags, outputMode);
- if (stdout_fd < 0)
+ if (stdout_fd < 0) {
open_error(settings->stdout_filename);
- if ( dup2(stdout_fd, STDOUT_FILENO) == -1 )
- myperror("dup2 for stdout");
+ goto child_failed;
+ }
+ if (dup2(stdout_fd, STDOUT_FILENO) == -1)
+ {
+ child_error("dup2 for stdout");
+ }
}
if (is_defined(settings->stderr_filename))
if (stderr_fd == -1)
{
stderr_fd = open(settings->stderr_filename, outputFlags, outputMode);
- if (stderr_fd == -1) open_error(settings->stderr_filename);
+ if (stderr_fd == -1)
+ {
+ open_error(settings->stderr_filename);
+ goto child_failed;
+ }
+ }
+ if (dup2(stderr_fd, STDERR_FILENO) == -1)
+ {
+ child_error("dup2 for stderr");
}
- if ( dup2(stderr_fd, STDERR_FILENO) == -1 )
- myperror("dup2 for stderr");
}
- res = execvp(settings->program, settings->argv); /* , settings->envp); */
+ update_environment(settings->envp);
+
+ execvp(settings->program, settings->argv);
myperror("Cannot execute %s", settings->program);
- return res;
+
+child_failed:
+ return 1;
}
/* Handles the termination of a process. Arguments:
int run_command(const command_settings *settings)
{
pid_t child_pid = fork();
- if (child_pid == -1) myperror("fork");
- if (child_pid == 0) return run_command_child(settings);
- else return run_command_parent(settings, child_pid);
+
+ switch (child_pid)
+ {
+ case -1:
+ myperror("fork");
+ return -1;
+ case 0: /* child process */
+ exit( run_command_child(settings) );
+ default:
+ return run_command_parent(settings, child_pid);
+ }
}
const command_settings *settings,
const char *message, const WCHAR *argument)
{
- WCHAR error_message[1024];
+ WCHAR windows_error_message[1024];
DWORD error = GetLastError();
- char *error_message_c;
- FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, error, 0,
- error_message, sizeof(error_message)/sizeof(WCHAR), NULL);
- error_message_c = caml_stat_strdup_of_utf16(error_message);
+ char *caml_error_message, buf[256];
+ if (FormatMessage(
+ FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
+ NULL, error, 0, windows_error_message,
+ sizeof(windows_error_message)/sizeof(WCHAR), NULL) ) {
+ caml_error_message = caml_stat_strdup_of_utf16(windows_error_message);
+ } else {
+ caml_error_message = caml_stat_alloc(256);
+ sprintf(caml_error_message, "unknown Windows error #%lu", error);
+ }
if ( is_defined(argument) )
error_with_location(file, line,
- settings, "%s %s: %s", message, argument, error_message_c);
+ settings, "%s %s: %s", message, argument, caml_error_message);
else
error_with_location(file, line,
- settings, "%s: %s", message, error_message_c);
- caml_stat_free(error_message_c);
+ settings, "%s: %s", message, caml_error_message);
+ caml_stat_free(caml_error_message);
}
static WCHAR *find_program(const WCHAR *program_name)
return commandline;
}
+static LPVOID prepare_environment(WCHAR **localenv)
+{
+ LPTCH p, r, env, process_env = NULL;
+ WCHAR **q;
+ int l, process_env_length, localenv_length, env_length;
+
+ if (localenv == NULL) return NULL;
+
+ process_env = GetEnvironmentStrings();
+ if (process_env == NULL) return NULL;
+
+ /* Compute length of process environment */
+ process_env_length = 0;
+ p = process_env;
+ while (*p != L'\0') {
+ l = wcslen(p) + 1; /* also count terminating '\0' */
+ process_env_length += l;
+ p += l;
+ }
+
+ /* Compute length of local environment */
+ localenv_length = 0;
+ q = localenv;
+ while (*q != NULL) {
+ localenv_length += wcslen(*q) + 1;
+ q++;
+ }
+
+ /* Build new env that contains both process and local env */
+ env_length = process_env_length + localenv_length + 1;
+ env = malloc(env_length * sizeof(WCHAR));
+ if (env == NULL) {
+ FreeEnvironmentStrings(process_env);
+ return NULL;
+ }
+ r = env;
+ p = process_env;
+ while (*p != L'\0') {
+ l = wcslen(p) + 1; /* also count terminating '\0' */
+ memcpy(r, p, l * sizeof(WCHAR));
+ p += l;
+ r += l;
+ }
+ FreeEnvironmentStrings(process_env);
+ q = localenv;
+ while (*q != NULL) {
+ l = wcslen(*q) + 1;
+ memcpy(r, *q, l * sizeof(WCHAR));
+ r += l;
+ q++;
+ }
+ *r = L'\0';
+ return env;
+}
+
static SECURITY_ATTRIBUTES security_attributes = {
sizeof(SECURITY_ATTRIBUTES), /* nLength */
NULL, /* lpSecurityDescriptor */
goto cleanup; \
} else { }
+static WCHAR *translate_finename(WCHAR *filename)
+{
+ if (!wcscmp(filename, L"/dev/null")) return L"NUL"; else return filename;
+}
+
int run_command(const command_settings *settings)
{
BOOL process_created = FALSE;
commandline = commandline_of_arguments(settings->argv);
+ environment = prepare_environment(settings->envp);
+
if (is_defined(settings->stdin_filename))
{
- startup_info.hStdInput = create_input_handle(settings->stdin_filename);
+ WCHAR *stdin_filename = translate_finename(settings->stdin_filename);
+ startup_info.hStdInput = create_input_handle(stdin_filename);
checkerr( (startup_info.hStdInput == INVALID_HANDLE_VALUE),
"Could not redirect standard input",
- settings->stdin_filename);
+ stdin_filename);
stdin_redirected = 1;
} else startup_info.hStdInput = GetStdHandle(STD_INPUT_HANDLE);
if (is_defined(settings->stdout_filename))
{
+ WCHAR *stdout_filename = translate_finename(settings->stdout_filename);
startup_info.hStdOutput = create_output_handle(
- settings->stdout_filename, settings->append
+ stdout_filename, settings->append
);
checkerr( (startup_info.hStdOutput == INVALID_HANDLE_VALUE),
"Could not redirect standard output",
- settings->stdout_filename);
+ stdout_filename);
stdout_redirected = 1;
} else startup_info.hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE);
if (! stderr_redirected)
{
+ WCHAR *stderr_filename = translate_finename(settings->stderr_filename);
startup_info.hStdError = create_output_handle
(
- settings->stderr_filename, settings->append
+ stderr_filename, settings->append
);
checkerr( (startup_info.hStdError == INVALID_HANDLE_VALUE),
"Could not redirect standard error",
- settings->stderr_filename);
+ stderr_filename);
stderr_redirected = 1;
}
} else startup_info.hStdError = GetStdHandle(STD_ERROR_HANDLE);
NULL, /* SECURITY_ATTRIBUTES thread_attributes */
TRUE, /* BOOL inherit_handles */
CREATE_UNICODE_ENVIRONMENT, /* DWORD creation_flags */
- NULL, /* LPVOID environment */
+ environment,
NULL, /* LPCSTR current_directory */
&startup_info,
&process_info
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
-(* *)
-(* Copyright 2016 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(* Miscellaneous library functions *)
-
-let rec concatmap f = function
- | [] -> []
- | x::xs -> (f x) @ (concatmap f xs)
-
-let is_blank c =
- c = ' ' || c = '\012' || c = '\n' || c = '\r' || c = '\t'
-
-let string_of_char = String.make 1
-
-(* This function comes from otherlibs/win32unix/unix.ml *)
-let maybe_quote f =
- if String.contains f ' ' ||
- String.contains f '\"' ||
- String.contains f '\t' ||
- f = ""
- then Filename.quote f
- else f
-
-let words s =
- let l = String.length s in
- let rec f quote w ws i =
- if i>=l then begin
- if w<>"" then List.rev (w::ws)
- else List.rev ws
- end else begin
- let j = i+1 in
- match s.[i] with
- | '\'' -> f (not quote) w ws j
- | ' ' ->
- begin
- if quote
- then f true (w ^ (string_of_char ' ')) ws j
- else begin
- if w=""
- then f false w ws j
- else f false "" (w::ws) j
- end
- end
- | _ as c -> f quote (w ^ (string_of_char c)) ws j
- end in
- if l=0 then [] else f false "" [] 0
-
-let file_is_empty filename =
- let ic = open_in filename in
- let filesize = in_channel_length ic in
- close_in ic;
- filesize = 0
-
-let string_of_location loc =
- let buf = Buffer.create 64 in
- let fmt = Format.formatter_of_buffer buf in
- Location.print_loc fmt loc;
- Format.pp_print_flush fmt ();
- Buffer.contents buf
-
-let run_system_command command = match Sys.command command with
- | 0 -> ()
- | _ as exitcode ->
- Printf.eprintf "Sysem command %s failed with status %d\n%!"
- command exitcode;
- exit 3
-
-let mkdir dir =
- if not (Sys.file_exists dir) then
- let quoted_dir = "\"" ^ dir ^ "\"" in
- run_system_command ("mkdir " ^ quoted_dir)
-
-let rec make_directory dir =
- if Sys.file_exists dir then ()
- else (make_directory (Filename.dirname dir); mkdir dir)
-
-let string_of_file filename =
- let chan = open_in_bin filename in
- let filesize = in_channel_length chan in
- if filesize > Sys.max_string_length then
- begin
- close_in chan;
- failwith
- ("The file " ^ filename ^ " is too large to be loaded into a string")
- end else begin
- let result =
- try really_input_string chan filesize
- with End_of_file ->
- close_in chan;
- failwith ("Got unexpected end of file while reading " ^ filename) in
- close_in chan;
- result
- end
-
-let with_input_file ?(bin=false) x f =
- let ic = (if bin then open_in_bin else open_in) x in
- try let res = f ic in close_in ic; res with e -> (close_in ic; raise e)
-
-let with_output_file ?(bin=false) x f =
- let oc = (if bin then open_out_bin else open_out) x in
- try let res = f oc in close_out oc; res with e -> (close_out oc; raise e)
-
-
-let copy_chan ic oc =
- let m = in_channel_length ic in
- let m = (m lsr 12) lsl 12 in
- let m = max 16384 (min Sys.max_string_length m) in
- let buf = Bytes.create m in
- let rec loop () =
- let len = input ic buf 0 m in
- if len > 0 then begin
- output oc buf 0 len;
- loop ()
- end
- in loop ()
-
-let copy_file src dest =
- with_input_file ~bin:true src begin fun ic ->
- with_output_file ~bin:true dest begin fun oc ->
- copy_chan ic oc
- end
- end
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Sebastien Hinderer, projet Gallium, INRIA Paris *)
-(* *)
-(* Copyright 2016 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(* Miscellaneous library functions *)
-
-val concatmap : ('a -> 'b list) -> 'a list -> 'b list
-
-val is_blank : char -> bool
-
-val maybe_quote : string -> string
-
-val words : string -> string list
-
-val file_is_empty : string -> bool
-
-val string_of_location: Location.t -> string
-
-val run_system_command : string -> unit
-
-val make_directory : string -> unit
-
-val string_of_file : string -> string
-
-val copy_file : string -> string -> unit
let test_of_action action =
{
- test_name = action.Actions.action_name;
+ test_name = Actions.action_name action;
test_run_by_default = false;
test_actions = [action]
}
let run_actions log testenv actions =
let total = List.length actions in
let rec run_actions_aux action_number env = function
- | [] -> Actions.Pass env
+ | [] -> (Result.pass, env)
| action::remaining_actions ->
begin
Printf.fprintf log "Running action %d/%d (%s)\n%!"
- action_number total action.Actions.action_name;
- let result = Actions.run log env action in
- let report = match result with
- | Actions.Pass _ -> "succeded."
- | Actions.Fail reason ->
- ("failed for the following reason:\n" ^ reason)
- | Actions.Skip reason ->
- ("has been skipped for the following reason:\n" ^ reason) in
+ action_number total (Actions.action_name action);
+ let (result, env') = Actions.run log env action in
Printf.fprintf log "Action %d/%d (%s) %s\n%!"
- action_number total action.Actions.action_name
- report;
- match result with
- | Actions.Pass env' ->
- run_actions_aux (action_number+1) env' remaining_actions
- | _ -> result
+ action_number total (Actions.action_name action)
+ (Result.string_of_result result);
+ if Result.is_pass result
+ then run_actions_aux (action_number+1) env' remaining_actions
+ else (result, env')
end in
run_actions_aux 1 testenv actions
val lookup : string -> t option
-val run : out_channel -> Environments.t -> t -> Actions.result
+val run : out_channel -> Environments.t -> t -> Result.t * Environments.t
val test_of_action : Actions.t -> t
}
type environment_statement =
- | Assignment of string located * string located (* variable = value *)
+ | Assignment of bool * string located * string located (* variable = value *)
+ | Append of string located * string located
| Include of string located (* include named environemnt *)
type tsl_item =
}
type environment_statement =
- | Assignment of string located * string located (* variable = value *)
+ | Assignment of bool * string located * string located (* variable = value *)
+ | Append of string located * string located (* variable += value *)
| Include of string located (* include named environemnt *)
type tsl_item =
let newline = ('\013'* '\010')
let blank = [' ' '\009' '\012']
-let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']
+let identchar = ['A'-'Z' 'a'-'z' '_' '.' '-' '\'' '0'-'9']
rule token = parse
| blank * { token lexbuf }
| "*)" { TSL_END_OCAML_STYLE }
| "," { COMA }
| '*'+ { TEST_DEPTH (String.length (Lexing.lexeme lexbuf)) }
+ | "+=" { PLUSEQUAL }
| "=" { EQUAL }
| identchar *
{ let s = Lexing.lexeme lexbuf in
match s with
| "include" -> INCLUDE
+ | "set" -> SET
| "with" -> WITH
| _ -> IDENTIFIER s
}
%token TSL_BEGIN_OCAML_STYLE TSL_END_OCAML_STYLE
%token COMA
%token <int> TEST_DEPTH
-%token EQUAL
+%token EQUAL PLUSEQUAL
/* %token COLON */
-%token INCLUDE WITH
+%token INCLUDE SET WITH
%token <string> IDENTIFIER
%token <string> STRING
env_item:
| identifier EQUAL string
- { mkenvstmt (Assignment ($1, $3)) }
+ { mkenvstmt (Assignment (false, $1, $3)) }
+| identifier PLUSEQUAL string
+ { mkenvstmt (Append ($1, $3)) }
+| SET identifier EQUAL string
+ { mkenvstmt (Assignment (true, $2, $4)) }
+
| INCLUDE identifier
{ mkenvstmt (Include $2) }
open Tsl_ast
-let variable_already_defined loc variable context =
- let ctxt = match context with
- | None -> ""
- | Some envname -> " while including environment " ^ envname in
- let locstr = Testlib.string_of_location loc in
- Printf.eprintf "%s\nVariable %s already defined%s\n%!" locstr variable ctxt;
+let string_of_location loc =
+ let buf = Buffer.create 64 in
+ let fmt = Format.formatter_of_buffer buf in
+ Location.print_loc fmt loc;
+ Format.pp_print_flush fmt ();
+ Buffer.contents buf
+
+let no_such_variable loc name =
+ let locstr = string_of_location loc in
+ Printf.eprintf "%s\nNo such variable %s\n%!" locstr name;
exit 2
let no_such_modifiers loc name =
- let locstr = Testlib.string_of_location loc in
+ let locstr = string_of_location loc in
Printf.eprintf "%s\nNo such modifiers %s\n%!" locstr name;
exit 2
try Environments.apply_modifier env modifier with
| Environments.Modifiers_name_not_found name ->
no_such_modifiers modifiers_name.loc name
- | Environments.Variable_already_defined variable ->
- variable_already_defined modifiers_name.loc
- (Variables.name_of_variable variable) (Some name)
+
+let rec add_to_env decl loc variable_name value env =
+ match (Variables.find_variable variable_name, decl) with
+ | (None, true) ->
+ let newvar = Variables.make (variable_name,"User variable") in
+ Variables.register_variable newvar;
+ add_to_env false loc variable_name value env
+ | (Some variable, false) ->
+ Environments.add variable value env
+ | (None, false) ->
+ raise (Variables.No_such_variable variable_name)
+ | (Some _, true) ->
+ raise (Variables.Variable_already_registered variable_name)
+
+let append_to_env loc variable_name value env =
+ let variable =
+ match Variables.find_variable variable_name with
+ | None ->
+ raise (Variables.No_such_variable variable_name)
+ | Some variable ->
+ variable
+ in
+ try
+ Environments.append variable value env
+ with Variables.No_such_variable name ->
+ no_such_variable loc name
let interprete_environment_statement env statement = match statement.node with
- | Assignment (var, value) ->
- begin
- let variable_name = var.node in
- let variable = match Variables.find_variable variable_name with
- | None -> Variables.make (variable_name, "User variable")
- | Some variable -> variable in
- try Environments.add variable value.node env with
- Environments.Variable_already_defined variable ->
- variable_already_defined statement.loc
- (Variables.name_of_variable variable) None
- end
- | Include modifiers_name -> apply_modifiers env modifiers_name
+ | Assignment (decl, var, value) ->
+ add_to_env decl statement.loc var.node value.node env
+ | Append (var, value) ->
+ append_to_env statement.loc var.node value.node env
+ | Include modifiers_name ->
+ apply_modifiers env modifiers_name
let interprete_environment_statements env l =
List.fold_left interprete_environment_statement env l
exit 2
let unexpected_environment_statement s =
- let locstr = Testlib.string_of_location s.loc in
+ let locstr = string_of_location s.loc in
Printf.eprintf "%s\nUnexpected environment statement\n%!" locstr;
exit 2
let no_such_test_or_action t =
- let locstr = Testlib.string_of_location t.loc in
+ let locstr = string_of_location t.loc in
Printf.eprintf "%s\nNo such test or action: %s\n%!" locstr t.node;
exit 2
(* *)
(**************************************************************************)
-(* Definition of environment variabless *)
+(* Definition of environment variables *)
+
+type value = string
+
+type exporter = value -> string
type t = {
variable_name : string;
- variable_description : string
+ variable_description : string;
+ variable_exporter : exporter
}
let compare v1 v2 = String.compare v1.variable_name v2.variable_name
exception Empty_variable_name
-exception Variable_already_registered
+exception Variable_already_registered of string
+
+exception No_such_variable of string
+
+let default_exporter varname value = Printf.sprintf "%s=%s" varname value
let make (name, description) =
if name="" then raise Empty_variable_name else {
variable_name = name;
- variable_description = description
+ variable_description = description;
+ variable_exporter = default_exporter name
+ }
+
+let make_with_exporter exporter (name, description) =
+ if name="" then raise Empty_variable_name else {
+ variable_name = name;
+ variable_description = description;
+ variable_exporter = exporter
}
let name_of_variable v = v.variable_name
let register_variable variable =
if Hashtbl.mem variables variable.variable_name
- then raise Variable_already_registered
+ then raise (Variable_already_registered variable.variable_name)
else Hashtbl.add variables variable.variable_name variable
let find_variable variable_name =
try Some (Hashtbl.find variables variable_name)
with Not_found -> None
+
+let string_of_binding variable value =
+ variable.variable_exporter value
(* *)
(**************************************************************************)
-(* Definition of environment variabless *)
+(* Definition of environment variables *)
+
+type value = string
+
+type exporter = value -> string
type t
exception Empty_variable_name
-exception Variable_already_registered
+exception Variable_already_registered of string
+
+exception No_such_variable of string
val make : string * string -> t
+val make_with_exporter : exporter -> string * string -> t
+
val name_of_variable : t -> string
val description_of_variable : t -> string
val register_variable : t -> unit
val find_variable : string -> t option
+
+val string_of_binding : t -> value -> string
ROOTDIR=../..
include $(ROOTDIR)/config/Makefile
+include $(ROOTDIR)/Makefile.common
+
CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
CAMLYACC ?= $(ROOTDIR)/boot/ocamlyacc
lib$(CLIBNAME).$(A): $(COBJS)
$(MKLIB) -oc $(CLIBNAME) $(COBJS) $(LDOPTS)
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
-
install::
if test -f dll$(CLIBNAME)$(EXT_DLL); then \
- cp dll$(CLIBNAME)$(EXT_DLL) "$(INSTALL_STUBLIBDIR)/"; fi
- cp lib$(CLIBNAME).$(A) "$(INSTALL_LIBDIR)/"
+ $(INSTALL_PROG) \
+ dll$(CLIBNAME)$(EXT_DLL) \
+ "$(INSTALL_STUBLIBDIR)/"; \
+ fi
+ $(INSTALL_DATA) lib$(CLIBNAME).$(A) "$(INSTALL_LIBDIR)/"
cd "$(INSTALL_LIBDIR)"; $(RANLIB) lib$(CLIBNAME).$(A)
- cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) \
- $(CMIFILES:.cmi=.cmti) "$(INSTALL_LIBDIR)/"
+ $(INSTALL_DATA) \
+ $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) \
+ $(CMIFILES:.cmi=.cmti) \
+ "$(INSTALL_LIBDIR)/"
if test -n "$(HEADERS)"; then \
- cp $(HEADERS) "$(INSTALL_LIBDIR)/caml/"; fi
+ $(INSTALL_DATA) $(HEADERS) "$(INSTALL_LIBDIR)/caml/"; \
+ fi
installopt:
- cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) "$(INSTALL_LIBDIR)/"
+ $(INSTALL_DATA) \
+ $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) \
+ "$(INSTALL_LIBDIR)/"
cd "$(INSTALL_LIBDIR)"; $(RANLIB) $(LIBNAME).a
if test -f $(LIBNAME).cmxs; then \
- cp $(LIBNAME).cmxs "$(INSTALL_LIBDIR)/"; fi
+ $(INSTALL_PROG) $(LIBNAME).cmxs "$(INSTALL_LIBDIR)/"; \
+ fi
partialclean:
rm -f *.cm*
-bigarray_stubs.$(O): bigarray_stubs.c ../../byterun/caml/alloc.h \
- ../../byterun/caml/misc.h ../../byterun/caml/config.h \
- ../../byterun/caml/m.h ../../byterun/caml/s.h \
- ../../byterun/caml/mlvalues.h ../../byterun/caml/bigarray.h \
- ../../byterun/caml/custom.h ../../byterun/caml/fail.h \
- ../../byterun/caml/intext.h ../../byterun/caml/io.h \
- ../../byterun/caml/hash.h ../../byterun/caml/memory.h \
- ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
- ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
- ../../byterun/caml/address_class.h ../../byterun/caml/signals.h
bigarray.cmo : bigarray.cmi
bigarray.cmx : bigarray.cmi
bigarray.cmi :
LIBNAME=bigarray
EXTRACFLAGS=-I../$(UNIXLIB) -DIN_OCAML_BIGARRAY
EXTRACAMLFLAGS=-I ../$(UNIXLIB)
-COBJS=bigarray_stubs.$(O) mmap_ba.$(O) mmap.$(O)
+COBJS=mmap_ba.$(O) mmap.$(O)
CAMLOBJS=bigarray.cmo
include ../Makefile
+ifeq "$(SYSTEM)" "mingw"
+LDOPTS=-ldopt "-link -static-libgcc"
+endif
+
mmap.$(O): ../$(UNIXLIB)/mmap.c
$(CC) -c $(CFLAGS) $(CPPFLAGS) $(OUTPUTOBJ)$@ $<
mmap_ba.$(O): ../unix/mmap_ba.c
.PHONY: depend
depend:
-ifeq "$(TOOLCHAIN)" "msvc"
- $(error Dependencies cannot be regenerated using the MSVC ports)
-else
- $(CC) -MM $(CFLAGS) $(CPPFLAGS) *.c | sed -e 's/\.o/.$$(O)/g' > .depend
- $(CAMLRUN) $(ROOTDIR)/tools/ocamldep -slash *.mli *.ml >> .depend
-endif
+ $(CAMLRUN) $(ROOTDIR)/tools/ocamldep -slash *.mli *.ml > .depend
include .depend
(* *)
(* OCaml *)
(* *)
-(* Manuel Serrano et Xavier Leroy, INRIA Rocquencourt *)
+(* Jeremie Dimino, Jane Street Europe *)
(* *)
-(* Copyright 2000 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
+(* Copyright 2018 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* *)
(**************************************************************************)
-(* Module [Bigarray]: large, multi-dimensional, numerical arrays *)
+module Super = Stdlib.Bigarray
-include CamlinternalBigarray
-
-(* Keep those constants in sync with the caml_ba_kind enumeration
- in bigarray.h *)
-
-let float32 = Float32
-let float64 = Float64
-let int8_signed = Int8_signed
-let int8_unsigned = Int8_unsigned
-let int16_signed = Int16_signed
-let int16_unsigned = Int16_unsigned
-let int32 = Int32
-let int64 = Int64
-let int = Int
-let nativeint = Nativeint
-let complex32 = Complex32
-let complex64 = Complex64
-let char = Char
-
-let kind_size_in_bytes : type a b. (a, b) kind -> int = function
- | Float32 -> 4
- | Float64 -> 8
- | Int8_signed -> 1
- | Int8_unsigned -> 1
- | Int16_signed -> 2
- | Int16_unsigned -> 2
- | Int32 -> 4
- | Int64 -> 8
- | Int -> Sys.word_size / 8
- | Nativeint -> Sys.word_size / 8
- | Complex32 -> 8
- | Complex64 -> 16
- | Char -> 1
-
-(* Keep those constants in sync with the caml_ba_layout enumeration
- in bigarray.h *)
-
-let c_layout = C_layout
-let fortran_layout = Fortran_layout
+include (Super : module type of struct include Super end
+ with module Genarray := Super.Genarray
+ with module Array1 := Super.Array1
+ with module Array2 := Super.Array2
+ with module Array3 := Super.Array3)
module Genarray = struct
- type ('a, 'b, 'c) t = ('a, 'b, 'c) genarray
- external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t
- = "caml_ba_create"
- external get: ('a, 'b, 'c) t -> int array -> 'a
- = "caml_ba_get_generic"
- external set: ('a, 'b, 'c) t -> int array -> 'a -> unit
- = "caml_ba_set_generic"
- external num_dims: ('a, 'b, 'c) t -> int = "caml_ba_num_dims"
- external nth_dim: ('a, 'b, 'c) t -> int -> int = "caml_ba_dim"
- let dims a =
- let n = num_dims a in
- let d = Array.make n 0 in
- for i = 0 to n-1 do d.(i) <- nth_dim a i done;
- d
-
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
- external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
- external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
- = "caml_ba_change_layout"
-
- let size_in_bytes arr =
- (kind_size_in_bytes (kind arr)) * (Array.fold_left ( * ) 1 (dims arr))
-
- external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
- = "caml_ba_sub"
- external sub_right: ('a, 'b, fortran_layout) t -> int -> int ->
- ('a, 'b, fortran_layout) t
- = "caml_ba_sub"
- external slice_left: ('a, 'b, c_layout) t -> int array ->
- ('a, 'b, c_layout) t
- = "caml_ba_slice"
- external slice_right: ('a, 'b, fortran_layout) t -> int array ->
- ('a, 'b, fortran_layout) t
- = "caml_ba_slice"
- external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
- = "caml_ba_blit"
- external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+ include Super.Genarray
external map_internal: Unix.file_descr -> ('a, 'b) kind -> 'c layout ->
- bool -> int array -> int64 -> ('a, 'b, 'c) t
- = "caml_ba_map_file_bytecode" "caml_ba_map_file"
+ bool -> int array -> int64 -> ('a, 'b, 'c) t
+ = "caml_ba_map_file_bytecode" "caml_ba_map_file"
let map_file fd ?(pos = 0L) kind layout shared dims =
map_internal fd kind layout shared dims pos
end
-module Array0 = struct
- type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
- let create kind layout =
- Genarray.create kind layout [||]
- let get arr = Genarray.get arr [||]
- let set arr = Genarray.set arr [||]
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
- external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
-
- external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
- = "caml_ba_change_layout"
-
- let size_in_bytes arr = kind_size_in_bytes (kind arr)
-
- external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
- external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
-
- let of_value kind layout v =
- let a = create kind layout in
- set a v;
- a
-end
-
module Array1 = struct
- type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
- let create kind layout dim =
- Genarray.create kind layout [|dim|]
- external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1"
- external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1"
- external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1"
- external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit
- = "%caml_ba_unsafe_set_1"
- external dim: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
- external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
-
- external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
- = "caml_ba_change_layout"
-
- let size_in_bytes arr =
- (kind_size_in_bytes (kind arr)) * (dim arr)
-
- external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "caml_ba_sub"
- let slice (type t) (a : (_, _, t) Genarray.t) n =
- match layout a with
- | C_layout -> (Genarray.slice_left a [|n|] : (_, _, t) Genarray.t)
- | Fortran_layout -> (Genarray.slice_right a [|n|]: (_, _, t) Genarray.t)
- external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
- external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
- let of_array (type t) kind (layout: t layout) data =
- let ba = create kind layout (Array.length data) in
- let ofs =
- match layout with
- C_layout -> 0
- | Fortran_layout -> 1
- in
- for i = 0 to Array.length data - 1 do unsafe_set ba (i + ofs) data.(i) done;
- ba
+ include Super.Array1
let map_file fd ?pos kind layout shared dim =
- Genarray.map_file fd ?pos kind layout shared [|dim|]
+ array1_of_genarray
+ (Genarray.map_file fd ?pos kind layout shared [|dim|])
end
module Array2 = struct
- type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
- let create kind layout dim1 dim2 =
- Genarray.create kind layout [|dim1; dim2|]
- external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2"
- external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2"
- external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a
- = "%caml_ba_unsafe_ref_2"
- external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit
- = "%caml_ba_unsafe_set_2"
- external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
- external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
- external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
-
- external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
- = "caml_ba_change_layout"
-
- let size_in_bytes arr =
- (kind_size_in_bytes (kind arr)) * (dim1 arr) * (dim2 arr)
-
- external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
- = "caml_ba_sub"
- external sub_right:
- ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
- = "caml_ba_sub"
- let slice_left a n = Genarray.slice_left a [|n|]
- let slice_right a n = Genarray.slice_right a [|n|]
- external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
- external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
- let of_array (type t) kind (layout: t layout) data =
- let dim1 = Array.length data in
- let dim2 = if dim1 = 0 then 0 else Array.length data.(0) in
- let ba = create kind layout dim1 dim2 in
- let ofs =
- match layout with
- C_layout -> 0
- | Fortran_layout -> 1
- in
- for i = 0 to dim1 - 1 do
- let row = data.(i) in
- if Array.length row <> dim2 then
- invalid_arg("Bigarray.Array2.of_array: non-rectangular data");
- for j = 0 to dim2 - 1 do
- unsafe_set ba (i + ofs) (j + ofs) row.(j)
- done
- done;
- ba
+ include Super.Array2
let map_file fd ?pos kind layout shared dim1 dim2 =
- Genarray.map_file fd ?pos kind layout shared [|dim1;dim2|]
+ array2_of_genarray
+ (Genarray.map_file fd ?pos kind layout shared [|dim1;dim2|])
end
module Array3 = struct
- type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
- let create kind layout dim1 dim2 dim3 =
- Genarray.create kind layout [|dim1; dim2; dim3|]
- external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3"
- external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
- = "%caml_ba_set_3"
- external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a
- = "%caml_ba_unsafe_ref_3"
- external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
- = "%caml_ba_unsafe_set_3"
- external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
- external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
- external dim3: ('a, 'b, 'c) t -> int = "%caml_ba_dim_3"
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
- external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
-
- external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
- = "caml_ba_change_layout"
-
- let size_in_bytes arr =
- (kind_size_in_bytes (kind arr)) * (dim1 arr) * (dim2 arr) * (dim3 arr)
-
- external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
- = "caml_ba_sub"
- external sub_right:
- ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
- = "caml_ba_sub"
- let slice_left_1 a n m = Genarray.slice_left a [|n; m|]
- let slice_right_1 a n m = Genarray.slice_right a [|n; m|]
- let slice_left_2 a n = Genarray.slice_left a [|n|]
- let slice_right_2 a n = Genarray.slice_right a [|n|]
- external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
- external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
- let of_array (type t) kind (layout: t layout) data =
- let dim1 = Array.length data in
- let dim2 = if dim1 = 0 then 0 else Array.length data.(0) in
- let dim3 = if dim2 = 0 then 0 else Array.length data.(0).(0) in
- let ba = create kind layout dim1 dim2 dim3 in
- let ofs =
- match layout with
- C_layout -> 0
- | Fortran_layout -> 1
- in
- for i = 0 to dim1 - 1 do
- let row = data.(i) in
- if Array.length row <> dim2 then
- invalid_arg("Bigarray.Array3.of_array: non-cubic data");
- for j = 0 to dim2 - 1 do
- let col = row.(j) in
- if Array.length col <> dim3 then
- invalid_arg("Bigarray.Array3.of_array: non-cubic data");
- for k = 0 to dim3 - 1 do
- unsafe_set ba (i + ofs) (j + ofs) (k + ofs) col.(k)
- done
- done
- done;
- ba
+ include Super.Array3
let map_file fd ?pos kind layout shared dim1 dim2 dim3 =
- Genarray.map_file fd ?pos kind layout shared [|dim1;dim2;dim3|]
+ array3_of_genarray
+ (Genarray.map_file fd ?pos kind layout shared [|dim1;dim2;dim3|])
end
-
-external genarray_of_array0: ('a, 'b, 'c) Array0.t -> ('a, 'b, 'c) Genarray.t
- = "%identity"
-external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t
- = "%identity"
-external genarray_of_array2: ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t
- = "%identity"
-external genarray_of_array3: ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t
- = "%identity"
-let array0_of_genarray a =
- if Genarray.num_dims a = 0 then a
- else invalid_arg "Bigarray.array0_of_genarray"
-let array1_of_genarray a =
- if Genarray.num_dims a = 1 then a
- else invalid_arg "Bigarray.array1_of_genarray"
-let array2_of_genarray a =
- if Genarray.num_dims a = 2 then a
- else invalid_arg "Bigarray.array2_of_genarray"
-let array3_of_genarray a =
- if Genarray.num_dims a = 3 then a
- else invalid_arg "Bigarray.array3_of_genarray"
-
-external reshape:
- ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t
- = "caml_ba_reshape"
-let reshape_0 a = reshape a [||]
-let reshape_1 a dim1 = reshape a [|dim1|]
-let reshape_2 a dim1 dim2 = reshape a [|dim1;dim2|]
-let reshape_3 a dim1 dim2 dim3 = reshape a [|dim1;dim2;dim3|]
-
-(* Force caml_ba_get_{1,2,3,N} to be linked in, since we don't refer
- to those primitives directly in this file *)
-
-let _ =
- let _ = Genarray.get in
- let _ = Array1.get in
- let _ = Array2.get in
- let _ = Array3.get in
- ()
-
-[@@@ocaml.warning "-32"]
-external get1: unit -> unit = "caml_ba_get_1"
-external get2: unit -> unit = "caml_ba_get_2"
-external get3: unit -> unit = "caml_ba_get_3"
-external set1: unit -> unit = "caml_ba_set_1"
-external set2: unit -> unit = "caml_ba_set_2"
-external set3: unit -> unit = "caml_ba_set_3"
(* *)
(* OCaml *)
(* *)
-(* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt *)
+(* Jeremie Dimino, Jane Street Europe *)
(* *)
-(* Copyright 2000 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
+(* Copyright 2018 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* *)
(**************************************************************************)
-(** Large, multi-dimensional, numerical arrays.
-
- This module implements multi-dimensional arrays of integers and
- floating-point numbers, thereafter referred to as 'big arrays'.
- The implementation allows efficient sharing of large numerical
- arrays between OCaml code and C or Fortran numerical libraries.
-
- Concerning the naming conventions, users of this module are encouraged
- to do [open Bigarray] in their source, then refer to array types and
- operations via short dot notation, e.g. [Array1.t] or [Array2.sub].
-
- Big arrays support all the OCaml ad-hoc polymorphic operations:
- - comparisons ([=], [<>], [<=], etc, as well as {!Pervasives.compare});
- - hashing (module [Hash]);
- - and structured input-output (the functions from the
- {!Marshal} module, as well as {!Pervasives.output_value}
- and {!Pervasives.input_value}).
-*)
-
-(** {1 Element kinds} *)
-
-(** Big arrays can contain elements of the following kinds:
-- IEEE single precision (32 bits) floating-point numbers
- ({!Bigarray.float32_elt}),
-- IEEE double precision (64 bits) floating-point numbers
- ({!Bigarray.float64_elt}),
-- IEEE single precision (2 * 32 bits) floating-point complex numbers
- ({!Bigarray.complex32_elt}),
-- IEEE double precision (2 * 64 bits) floating-point complex numbers
- ({!Bigarray.complex64_elt}),
-- 8-bit integers (signed or unsigned)
- ({!Bigarray.int8_signed_elt} or {!Bigarray.int8_unsigned_elt}),
-- 16-bit integers (signed or unsigned)
- ({!Bigarray.int16_signed_elt} or {!Bigarray.int16_unsigned_elt}),
-- OCaml integers (signed, 31 bits on 32-bit architectures,
- 63 bits on 64-bit architectures) ({!Bigarray.int_elt}),
-- 32-bit signed integers ({!Bigarray.int32_elt}),
-- 64-bit signed integers ({!Bigarray.int64_elt}),
-- platform-native signed integers (32 bits on 32-bit architectures,
- 64 bits on 64-bit architectures) ({!Bigarray.nativeint_elt}).
-
- Each element kind is represented at the type level by one of the
- [*_elt] types defined below (defined with a single constructor instead
- of abstract types for technical injectivity reasons).
-*)
-
-type float32_elt = CamlinternalBigarray.float32_elt = Float32_elt
-type float64_elt = CamlinternalBigarray.float64_elt = Float64_elt
-type int8_signed_elt = CamlinternalBigarray.int8_signed_elt = Int8_signed_elt
-type int8_unsigned_elt = CamlinternalBigarray.int8_unsigned_elt =
- Int8_unsigned_elt
-type int16_signed_elt = CamlinternalBigarray.int16_signed_elt =
- Int16_signed_elt
-type int16_unsigned_elt = CamlinternalBigarray.int16_unsigned_elt =
- Int16_unsigned_elt
-type int32_elt = CamlinternalBigarray.int32_elt = Int32_elt
-type int64_elt = CamlinternalBigarray.int64_elt = Int64_elt
-type int_elt = CamlinternalBigarray.int_elt = Int_elt
-type nativeint_elt = CamlinternalBigarray.nativeint_elt = Nativeint_elt
-type complex32_elt = CamlinternalBigarray.complex32_elt = Complex32_elt
-type complex64_elt = CamlinternalBigarray.complex64_elt = Complex64_elt
-
-type ('a, 'b) kind = ('a, 'b) CamlinternalBigarray.kind =
- Float32 : (float, float32_elt) kind
- | Float64 : (float, float64_elt) kind
- | Int8_signed : (int, int8_signed_elt) kind
- | Int8_unsigned : (int, int8_unsigned_elt) kind
- | Int16_signed : (int, int16_signed_elt) kind
- | Int16_unsigned : (int, int16_unsigned_elt) kind
- | Int32 : (int32, int32_elt) kind
- | Int64 : (int64, int64_elt) kind
- | Int : (int, int_elt) kind
- | Nativeint : (nativeint, nativeint_elt) kind
- | Complex32 : (Complex.t, complex32_elt) kind
- | Complex64 : (Complex.t, complex64_elt) kind
- | Char : (char, int8_unsigned_elt) kind (**)
-(** To each element kind is associated an OCaml type, which is
- the type of OCaml values that can be stored in the big array
- or read back from it. This type is not necessarily the same
- as the type of the array elements proper: for instance,
- a big array whose elements are of kind [float32_elt] contains
- 32-bit single precision floats, but reading or writing one of
- its elements from OCaml uses the OCaml type [float], which is
- 64-bit double precision floats.
-
- The GADT type [('a, 'b) kind] captures this association
- of an OCaml type ['a] for values read or written in the big array,
- and of an element kind ['b] which represents the actual contents
- of the big array. Its constructors list all possible associations
- of OCaml types with element kinds, and are re-exported below for
- backward-compatibility reasons.
-
- Using a generalized algebraic datatype (GADT) here allows to write
- well-typed polymorphic functions whose return type depend on the
- argument type, such as:
-
-{[
- let zero : type a b. (a, b) kind -> a = function
- | Float32 -> 0.0 | Complex32 -> Complex.zero
- | Float64 -> 0.0 | Complex64 -> Complex.zero
- | Int8_signed -> 0 | Int8_unsigned -> 0
- | Int16_signed -> 0 | Int16_unsigned -> 0
- | Int32 -> 0l | Int64 -> 0L
- | Int -> 0 | Nativeint -> 0n
- | Char -> '\000'
-]}
-*)
-
-val float32 : (float, float32_elt) kind
-(** See {!Bigarray.char}. *)
-
-val float64 : (float, float64_elt) kind
-(** See {!Bigarray.char}. *)
-
-val complex32 : (Complex.t, complex32_elt) kind
-(** See {!Bigarray.char}. *)
-
-val complex64 : (Complex.t, complex64_elt) kind
-(** See {!Bigarray.char}. *)
-
-val int8_signed : (int, int8_signed_elt) kind
-(** See {!Bigarray.char}. *)
-
-val int8_unsigned : (int, int8_unsigned_elt) kind
-(** See {!Bigarray.char}. *)
-
-val int16_signed : (int, int16_signed_elt) kind
-(** See {!Bigarray.char}. *)
-
-val int16_unsigned : (int, int16_unsigned_elt) kind
-(** See {!Bigarray.char}. *)
-
-val int : (int, int_elt) kind
-(** See {!Bigarray.char}. *)
-
-val int32 : (int32, int32_elt) kind
-(** See {!Bigarray.char}. *)
-
-val int64 : (int64, int64_elt) kind
-(** See {!Bigarray.char}. *)
-
-val nativeint : (nativeint, nativeint_elt) kind
-(** See {!Bigarray.char}. *)
-
-val char : (char, int8_unsigned_elt) kind
-(** As shown by the types of the values above,
- big arrays of kind [float32_elt] and [float64_elt] are
- accessed using the OCaml type [float]. Big arrays of complex kinds
- [complex32_elt], [complex64_elt] are accessed with the OCaml type
- {!Complex.t}. Big arrays of
- integer kinds are accessed using the smallest OCaml integer
- type large enough to represent the array elements:
- [int] for 8- and 16-bit integer bigarrays, as well as OCaml-integer
- bigarrays; [int32] for 32-bit integer bigarrays; [int64]
- for 64-bit integer bigarrays; and [nativeint] for
- platform-native integer bigarrays. Finally, big arrays of
- kind [int8_unsigned_elt] can also be accessed as arrays of
- characters instead of arrays of small integers, by using
- the kind value [char] instead of [int8_unsigned]. *)
-
-val kind_size_in_bytes : ('a, 'b) kind -> int
-(** [kind_size_in_bytes k] is the number of bytes used to store
- an element of type [k].
-
- @since 4.03.0 *)
-
-(** {1 Array layouts} *)
-
-type c_layout = CamlinternalBigarray.c_layout = C_layout_typ (**)
-(** See {!Bigarray.fortran_layout}.*)
-
-type fortran_layout = CamlinternalBigarray.fortran_layout =
- Fortran_layout_typ (**)
-(** To facilitate interoperability with existing C and Fortran code,
- this library supports two different memory layouts for big arrays,
- one compatible with the C conventions,
- the other compatible with the Fortran conventions.
-
- In the C-style layout, array indices start at 0, and
- multi-dimensional arrays are laid out in row-major format.
- That is, for a two-dimensional array, all elements of
- row 0 are contiguous in memory, followed by all elements of
- row 1, etc. In other terms, the array elements at [(x,y)]
- and [(x, y+1)] are adjacent in memory.
-
- In the Fortran-style layout, array indices start at 1, and
- multi-dimensional arrays are laid out in column-major format.
- That is, for a two-dimensional array, all elements of
- column 0 are contiguous in memory, followed by all elements of
- column 1, etc. In other terms, the array elements at [(x,y)]
- and [(x+1, y)] are adjacent in memory.
-
- Each layout style is identified at the type level by the
- phantom types {!Bigarray.c_layout} and {!Bigarray.fortran_layout}
- respectively. *)
-
-(** {7 Supported layouts}
-
- The GADT type ['a layout] represents one of the two supported
- memory layouts: C-style or Fortran-style. Its constructors are
- re-exported as values below for backward-compatibility reasons.
-*)
-
-type 'a layout = 'a CamlinternalBigarray.layout =
- C_layout: c_layout layout
- | Fortran_layout: fortran_layout layout
-
-val c_layout : c_layout layout
-val fortran_layout : fortran_layout layout
-
-
-(** {1 Generic arrays (of arbitrarily many dimensions)} *)
-
-module Genarray :
- sig
- type ('a, 'b, 'c) t = ('a, 'b, 'c) CamlinternalBigarray.genarray
- (** The type [Genarray.t] is the type of big arrays with variable
- numbers of dimensions. Any number of dimensions between 0 and 16
- is supported.
-
- The three type parameters to [Genarray.t] identify the array element
- kind and layout, as follows:
- - the first parameter, ['a], is the OCaml type for accessing array
- elements ([float], [int], [int32], [int64], [nativeint]);
- - the second parameter, ['b], is the actual kind of array elements
- ([float32_elt], [float64_elt], [int8_signed_elt], [int8_unsigned_elt],
- etc);
- - the third parameter, ['c], identifies the array layout
- ([c_layout] or [fortran_layout]).
-
- For instance, [(float, float32_elt, fortran_layout) Genarray.t]
- is the type of generic big arrays containing 32-bit floats
- in Fortran layout; reads and writes in this array use the
- OCaml type [float]. *)
-
- external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t
- = "caml_ba_create"
- (** [Genarray.create kind layout dimensions] returns a new big array
- whose element kind is determined by the parameter [kind] (one of
- [float32], [float64], [int8_signed], etc) and whose layout is
- determined by the parameter [layout] (one of [c_layout] or
- [fortran_layout]). The [dimensions] parameter is an array of
- integers that indicate the size of the big array in each dimension.
- The length of [dimensions] determines the number of dimensions
- of the bigarray.
-
- For instance, [Genarray.create int32 c_layout [|4;6;8|]]
- returns a fresh big array of 32-bit integers, in C layout,
- having three dimensions, the three dimensions being 4, 6 and 8
- respectively.
-
- Big arrays returned by [Genarray.create] are not initialized:
- the initial values of array elements is unspecified.
-
- [Genarray.create] raises [Invalid_argument] if the number of dimensions
- is not in the range 0 to 16 inclusive, or if one of the dimensions
- is negative. *)
-
- external num_dims: ('a, 'b, 'c) t -> int = "caml_ba_num_dims"
- (** Return the number of dimensions of the given big array. *)
-
- val dims : ('a, 'b, 'c) t -> int array
- (** [Genarray.dims a] returns all dimensions of the big array [a],
- as an array of integers of length [Genarray.num_dims a]. *)
-
- external nth_dim: ('a, 'b, 'c) t -> int -> int = "caml_ba_dim"
- (** [Genarray.nth_dim a n] returns the [n]-th dimension of the
- big array [a]. The first dimension corresponds to [n = 0];
- the second dimension corresponds to [n = 1]; the last dimension,
- to [n = Genarray.num_dims a - 1].
- Raise [Invalid_argument] if [n] is less than 0 or greater or equal than
- [Genarray.num_dims a]. *)
-
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
- (** Return the kind of the given big array. *)
-
- external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
- (** Return the layout of the given big array. *)
-
- external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
- = "caml_ba_change_layout"
- (** [Genarray.change_layout a layout] returns a bigarray with the
- specified [layout], sharing the data with [a] (and hence having
- the same dimensions as [a]). No copying of elements is involved: the
- new array and the original array share the same storage space.
- The dimensions are reversed, such that [get v [| a; b |]] in
- C layout becomes [get v [| b+1; a+1 |]] in Fortran layout.
-
- @since 4.04.0
- *)
-
- val size_in_bytes : ('a, 'b, 'c) t -> int
- (** [size_in_bytes a] is the number of elements in [a] multiplied
- by [a]'s {!kind_size_in_bytes}.
-
- @since 4.03.0 *)
-
- external get: ('a, 'b, 'c) t -> int array -> 'a = "caml_ba_get_generic"
- (** Read an element of a generic big array.
- [Genarray.get a [|i1; ...; iN|]] returns the element of [a]
- whose coordinates are [i1] in the first dimension, [i2] in
- the second dimension, ..., [iN] in the [N]-th dimension.
-
- If [a] has C layout, the coordinates must be greater or equal than 0
- and strictly less than the corresponding dimensions of [a].
- If [a] has Fortran layout, the coordinates must be greater or equal
- than 1 and less or equal than the corresponding dimensions of [a].
- Raise [Invalid_argument] if the array [a] does not have exactly [N]
- dimensions, or if the coordinates are outside the array bounds.
-
- If [N > 3], alternate syntax is provided: you can write
- [a.{i1, i2, ..., iN}] instead of [Genarray.get a [|i1; ...; iN|]].
- (The syntax [a.{...}] with one, two or three coordinates is
- reserved for accessing one-, two- and three-dimensional arrays
- as described below.) *)
-
- external set: ('a, 'b, 'c) t -> int array -> 'a -> unit
- = "caml_ba_set_generic"
- (** Assign an element of a generic big array.
- [Genarray.set a [|i1; ...; iN|] v] stores the value [v] in the
- element of [a] whose coordinates are [i1] in the first dimension,
- [i2] in the second dimension, ..., [iN] in the [N]-th dimension.
-
- The array [a] must have exactly [N] dimensions, and all coordinates
- must lie inside the array bounds, as described for [Genarray.get];
- otherwise, [Invalid_argument] is raised.
-
- If [N > 3], alternate syntax is provided: you can write
- [a.{i1, i2, ..., iN} <- v] instead of
- [Genarray.set a [|i1; ...; iN|] v].
- (The syntax [a.{...} <- v] with one, two or three coordinates is
- reserved for updating one-, two- and three-dimensional arrays
- as described below.) *)
-
- external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
- = "caml_ba_sub"
- (** Extract a sub-array of the given big array by restricting the
- first (left-most) dimension. [Genarray.sub_left a ofs len]
- returns a big array with the same number of dimensions as [a],
- and the same dimensions as [a], except the first dimension,
- which corresponds to the interval [[ofs ... ofs + len - 1]]
- of the first dimension of [a]. No copying of elements is
- involved: the sub-array and the original array share the same
- storage space. In other terms, the element at coordinates
- [[|i1; ...; iN|]] of the sub-array is identical to the
- element at coordinates [[|i1+ofs; ...; iN|]] of the original
- array [a].
-
- [Genarray.sub_left] applies only to big arrays in C layout.
- Raise [Invalid_argument] if [ofs] and [len] do not designate
- a valid sub-array of [a], that is, if [ofs < 0], or [len < 0],
- or [ofs + len > Genarray.nth_dim a 0]. *)
-
- external sub_right:
- ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
- = "caml_ba_sub"
- (** Extract a sub-array of the given big array by restricting the
- last (right-most) dimension. [Genarray.sub_right a ofs len]
- returns a big array with the same number of dimensions as [a],
- and the same dimensions as [a], except the last dimension,
- which corresponds to the interval [[ofs ... ofs + len - 1]]
- of the last dimension of [a]. No copying of elements is
- involved: the sub-array and the original array share the same
- storage space. In other terms, the element at coordinates
- [[|i1; ...; iN|]] of the sub-array is identical to the
- element at coordinates [[|i1; ...; iN+ofs|]] of the original
- array [a].
-
- [Genarray.sub_right] applies only to big arrays in Fortran layout.
- Raise [Invalid_argument] if [ofs] and [len] do not designate
- a valid sub-array of [a], that is, if [ofs < 1], or [len < 0],
- or [ofs + len > Genarray.nth_dim a (Genarray.num_dims a - 1)]. *)
-
- external slice_left:
- ('a, 'b, c_layout) t -> int array -> ('a, 'b, c_layout) t
- = "caml_ba_slice"
- (** Extract a sub-array of lower dimension from the given big array
- by fixing one or several of the first (left-most) coordinates.
- [Genarray.slice_left a [|i1; ... ; iM|]] returns the 'slice'
- of [a] obtained by setting the first [M] coordinates to
- [i1], ..., [iM]. If [a] has [N] dimensions, the slice has
- dimension [N - M], and the element at coordinates
- [[|j1; ...; j(N-M)|]] in the slice is identical to the element
- at coordinates [[|i1; ...; iM; j1; ...; j(N-M)|]] in the original
- array [a]. No copying of elements is involved: the slice and
- the original array share the same storage space.
-
- [Genarray.slice_left] applies only to big arrays in C layout.
- Raise [Invalid_argument] if [M >= N], or if [[|i1; ... ; iM|]]
- is outside the bounds of [a]. *)
-
- external slice_right:
- ('a, 'b, fortran_layout) t -> int array -> ('a, 'b, fortran_layout) t
- = "caml_ba_slice"
- (** Extract a sub-array of lower dimension from the given big array
- by fixing one or several of the last (right-most) coordinates.
- [Genarray.slice_right a [|i1; ... ; iM|]] returns the 'slice'
- of [a] obtained by setting the last [M] coordinates to
- [i1], ..., [iM]. If [a] has [N] dimensions, the slice has
- dimension [N - M], and the element at coordinates
- [[|j1; ...; j(N-M)|]] in the slice is identical to the element
- at coordinates [[|j1; ...; j(N-M); i1; ...; iM|]] in the original
- array [a]. No copying of elements is involved: the slice and
- the original array share the same storage space.
-
- [Genarray.slice_right] applies only to big arrays in Fortran layout.
- Raise [Invalid_argument] if [M >= N], or if [[|i1; ... ; iM|]]
- is outside the bounds of [a]. *)
-
- external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
- = "caml_ba_blit"
- (** Copy all elements of a big array in another big array.
- [Genarray.blit src dst] copies all elements of [src] into
- [dst]. Both arrays [src] and [dst] must have the same number of
- dimensions and equal dimensions. Copying a sub-array of [src]
- to a sub-array of [dst] can be achieved by applying [Genarray.blit]
- to sub-array or slices of [src] and [dst]. *)
-
- external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
- (** Set all elements of a big array to a given value.
- [Genarray.fill a v] stores the value [v] in all elements of
- the big array [a]. Setting only some elements of [a] to [v]
- can be achieved by applying [Genarray.fill] to a sub-array
- or a slice of [a]. *)
+include module type of struct include Stdlib.Bigarray end
+ with module Genarray := Stdlib.Bigarray.Genarray
+ with module Array1 := Stdlib.Bigarray.Array1
+ with module Array2 := Stdlib.Bigarray.Array2
+ with module Array3 := Stdlib.Bigarray.Array3
+module Genarray : sig
+ include module type of struct include Stdlib.Bigarray.Genarray end
val map_file:
Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout ->
bool -> int array -> ('a, 'b, 'c) t
Use Unix.map_file instead.\n\
Note that Bigarray.Genarray.map_file raises Sys_error while\n\
Unix.map_file raises Unix_error."]
- end
-
-(** {1 Zero-dimensional arrays} *)
-
-(** Zero-dimensional arrays. The [Array0] structure provides operations
- similar to those of {!Bigarray.Genarray}, but specialized to the case
- of zero-dimensional arrays that only contain a single scalar value.
- Statically knowing the number of dimensions of the array allows
- faster operations, and more precise static type-checking.
- @since 4.05.0 *)
-module Array0 : sig
- type ('a, 'b, 'c) t
- (** The type of zero-dimensional big arrays whose elements have
- OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
-
- val create: ('a, 'b) kind -> 'c layout -> ('a, 'b, 'c) t
- (** [Array0.create kind layout] returns a new bigarray of zero dimension.
- [kind] and [layout] determine the array element kind and the array
- layout as described for {!Genarray.create}. *)
-
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
- (** Return the kind of the given big array. *)
-
- external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
- (** Return the layout of the given big array. *)
-
- val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
- (** [Array0.change_layout a layout] returns a big array with the
- specified [layout], sharing the data with [a]. No copying of elements
- is involved: the new array and the original array share the same
- storage space.
-
- @since 4.06.0
- *)
-
- val size_in_bytes : ('a, 'b, 'c) t -> int
- (** [size_in_bytes a] is [a]'s {!kind_size_in_bytes}. *)
-
- val get: ('a, 'b, 'c) t -> 'a
- (** [Array0.get a] returns the only element in [a]. *)
-
- val set: ('a, 'b, 'c) t -> 'a -> unit
- (** [Array0.set a x v] stores the value [v] in [a]. *)
-
- external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
- (** Copy the first big array to the second big array.
- See {!Genarray.blit} for more details. *)
-
- external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
- (** Fill the given big array with the given value.
- See {!Genarray.fill} for more details. *)
-
- val of_value: ('a, 'b) kind -> 'c layout -> 'a -> ('a, 'b, 'c) t
- (** Build a zero-dimensional big array initialized from the
- given value. *)
-
end
-
-(** {1 One-dimensional arrays} *)
-
-(** One-dimensional arrays. The [Array1] structure provides operations
- similar to those of
- {!Bigarray.Genarray}, but specialized to the case of one-dimensional arrays.
- (The {!Array2} and {!Array3} structures below provide operations
- specialized for two- and three-dimensional arrays.)
- Statically knowing the number of dimensions of the array allows
- faster operations, and more precise static type-checking. *)
module Array1 : sig
- type ('a, 'b, 'c) t
- (** The type of one-dimensional big arrays whose elements have
- OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
-
- val create: ('a, 'b) kind -> 'c layout -> int -> ('a, 'b, 'c) t
- (** [Array1.create kind layout dim] returns a new bigarray of
- one dimension, whose size is [dim]. [kind] and [layout]
- determine the array element kind and the array layout
- as described for {!Genarray.create}. *)
-
- external dim: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
- (** Return the size (dimension) of the given one-dimensional
- big array. *)
-
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
- (** Return the kind of the given big array. *)
-
- external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
- (** Return the layout of the given big array. *)
-
- val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
- (** [Array1.change_layout a layout] returns a bigarray with the
- specified [layout], sharing the data with [a] (and hence having
- the same dimension as [a]). No copying of elements is involved: the
- new array and the original array share the same storage space.
-
- @since 4.06.0
- *)
-
-
- val size_in_bytes : ('a, 'b, 'c) t -> int
- (** [size_in_bytes a] is the number of elements in [a]
- multiplied by [a]'s {!kind_size_in_bytes}.
-
- @since 4.03.0 *)
-
- external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1"
- (** [Array1.get a x], or alternatively [a.{x}],
- returns the element of [a] at index [x].
- [x] must be greater or equal than [0] and strictly less than
- [Array1.dim a] if [a] has C layout. If [a] has Fortran layout,
- [x] must be greater or equal than [1] and less or equal than
- [Array1.dim a]. Otherwise, [Invalid_argument] is raised. *)
-
- external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1"
- (** [Array1.set a x v], also written [a.{x} <- v],
- stores the value [v] at index [x] in [a].
- [x] must be inside the bounds of [a] as described in
- {!Bigarray.Array1.get};
- otherwise, [Invalid_argument] is raised. *)
-
- external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t
- = "caml_ba_sub"
- (** Extract a sub-array of the given one-dimensional big array.
- See {!Genarray.sub_left} for more details. *)
-
- val slice: ('a, 'b, 'c) t -> int -> ('a, 'b, 'c) Array0.t
- (** Extract a scalar (zero-dimensional slice) of the given one-dimensional
- big array. The integer parameter is the index of the scalar to
- extract. See {!Bigarray.Genarray.slice_left} and
- {!Bigarray.Genarray.slice_right} for more details.
- @since 4.05.0 *)
-
- external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
- = "caml_ba_blit"
- (** Copy the first big array to the second big array.
- See {!Genarray.blit} for more details. *)
-
- external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
- (** Fill the given big array with the given value.
- See {!Genarray.fill} for more details. *)
-
- val of_array: ('a, 'b) kind -> 'c layout -> 'a array -> ('a, 'b, 'c) t
- (** Build a one-dimensional big array initialized from the
- given array. *)
-
+ include module type of struct include Stdlib.Bigarray.Array1 end
val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout ->
bool -> int -> ('a, 'b, 'c) t
[@@ocaml.deprecated "\
Use [array1_of_genarray (Unix.map_file ...)] instead.\n\
Note that Bigarray.Array1.map_file raises Sys_error while\n\
Unix.map_file raises Unix_error."]
-
- external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1"
- (** Like {!Bigarray.Array1.get}, but bounds checking is not always performed.
- Use with caution and only when the program logic guarantees that
- the access is within bounds. *)
-
- external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit
- = "%caml_ba_unsafe_set_1"
- (** Like {!Bigarray.Array1.set}, but bounds checking is not always performed.
- Use with caution and only when the program logic guarantees that
- the access is within bounds. *)
-
end
-
-(** {1 Two-dimensional arrays} *)
-
-(** Two-dimensional arrays. The [Array2] structure provides operations
- similar to those of {!Bigarray.Genarray}, but specialized to the
- case of two-dimensional arrays. *)
-module Array2 :
- sig
- type ('a, 'b, 'c) t
- (** The type of two-dimensional big arrays whose elements have
- OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
-
- val create: ('a, 'b) kind -> 'c layout -> int -> int -> ('a, 'b, 'c) t
- (** [Array2.create kind layout dim1 dim2] returns a new bigarray of
- two dimension, whose size is [dim1] in the first dimension
- and [dim2] in the second dimension. [kind] and [layout]
- determine the array element kind and the array layout
- as described for {!Bigarray.Genarray.create}. *)
-
- external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
- (** Return the first dimension of the given two-dimensional big array. *)
-
- external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
- (** Return the second dimension of the given two-dimensional big array. *)
-
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
- (** Return the kind of the given big array. *)
-
- external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
- (** Return the layout of the given big array. *)
-
- val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
- (** [Array2.change_layout a layout] returns a bigarray with the
- specified [layout], sharing the data with [a] (and hence having
- the same dimensions as [a]). No copying of elements is involved: the
- new array and the original array share the same storage space.
- The dimensions are reversed, such that [get v [| a; b |]] in
- C layout becomes [get v [| b+1; a+1 |]] in Fortran layout.
-
- @since 4.06.0
- *)
-
-
- val size_in_bytes : ('a, 'b, 'c) t -> int
- (** [size_in_bytes a] is the number of elements in [a]
- multiplied by [a]'s {!kind_size_in_bytes}.
-
- @since 4.03.0 *)
-
- external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2"
- (** [Array2.get a x y], also written [a.{x,y}],
- returns the element of [a] at coordinates ([x], [y]).
- [x] and [y] must be within the bounds
- of [a], as described for {!Bigarray.Genarray.get};
- otherwise, [Invalid_argument] is raised. *)
-
- external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2"
- (** [Array2.set a x y v], or alternatively [a.{x,y} <- v],
- stores the value [v] at coordinates ([x], [y]) in [a].
- [x] and [y] must be within the bounds of [a],
- as described for {!Bigarray.Genarray.set};
- otherwise, [Invalid_argument] is raised. *)
-
- external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
- = "caml_ba_sub"
- (** Extract a two-dimensional sub-array of the given two-dimensional
- big array by restricting the first dimension.
- See {!Bigarray.Genarray.sub_left} for more details.
- [Array2.sub_left] applies only to arrays with C layout. *)
-
- external sub_right:
- ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
- = "caml_ba_sub"
- (** Extract a two-dimensional sub-array of the given two-dimensional
- big array by restricting the second dimension.
- See {!Bigarray.Genarray.sub_right} for more details.
- [Array2.sub_right] applies only to arrays with Fortran layout. *)
-
- val slice_left: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array1.t
- (** Extract a row (one-dimensional slice) of the given two-dimensional
- big array. The integer parameter is the index of the row to
- extract. See {!Bigarray.Genarray.slice_left} for more details.
- [Array2.slice_left] applies only to arrays with C layout. *)
-
- val slice_right:
- ('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array1.t
- (** Extract a column (one-dimensional slice) of the given
- two-dimensional big array. The integer parameter is the
- index of the column to extract. See {!Bigarray.Genarray.slice_right}
- for more details. [Array2.slice_right] applies only to arrays
- with Fortran layout. *)
-
- external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
- = "caml_ba_blit"
- (** Copy the first big array to the second big array.
- See {!Bigarray.Genarray.blit} for more details. *)
-
- external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
- (** Fill the given big array with the given value.
- See {!Bigarray.Genarray.fill} for more details. *)
-
- val of_array: ('a, 'b) kind -> 'c layout -> 'a array array -> ('a, 'b, 'c) t
- (** Build a two-dimensional big array initialized from the
- given array of arrays. *)
-
+module Array2 : sig
+ include module type of struct include Stdlib.Bigarray.Array2 end
val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout ->
bool -> int -> int -> ('a, 'b, 'c) t
[@@ocaml.deprecated "\
Use [array2_of_genarray (Unix.map_file ...)] instead.\n\
Note that Bigarray.Array2.map_file raises Sys_error while\n\
Unix.map_file raises Unix_error."]
-
- external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a
- = "%caml_ba_unsafe_ref_2"
- (** Like {!Bigarray.Array2.get}, but bounds checking is not always
- performed. *)
-
- external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit
- = "%caml_ba_unsafe_set_2"
- (** Like {!Bigarray.Array2.set}, but bounds checking is not always
- performed. *)
-
end
-(** {1 Three-dimensional arrays} *)
-
-(** Three-dimensional arrays. The [Array3] structure provides operations
- similar to those of {!Bigarray.Genarray}, but specialized to the case
- of three-dimensional arrays. *)
-module Array3 :
- sig
- type ('a, 'b, 'c) t
- (** The type of three-dimensional big arrays whose elements have
- OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
-
- val create: ('a, 'b) kind -> 'c layout -> int -> int -> int -> ('a, 'b, 'c) t
- (** [Array3.create kind layout dim1 dim2 dim3] returns a new bigarray of
- three dimension, whose size is [dim1] in the first dimension,
- [dim2] in the second dimension, and [dim3] in the third.
- [kind] and [layout] determine the array element kind and
- the array layout as described for {!Bigarray.Genarray.create}. *)
-
- external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
- (** Return the first dimension of the given three-dimensional big array. *)
-
- external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
- (** Return the second dimension of the given three-dimensional big array. *)
-
- external dim3: ('a, 'b, 'c) t -> int = "%caml_ba_dim_3"
- (** Return the third dimension of the given three-dimensional big array. *)
-
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
- (** Return the kind of the given big array. *)
-
- external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
- (** Return the layout of the given big array. *)
-
-
- val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
- (** [Array3.change_layout a layout] returns a bigarray with the
- specified [layout], sharing the data with [a] (and hence having
- the same dimensions as [a]). No copying of elements is involved: the
- new array and the original array share the same storage space.
- The dimensions are reversed, such that [get v [| a; b; c |]] in
- C layout becomes [get v [| c+1; b+1; a+1 |]] in Fortran layout.
-
- @since 4.06.0
- *)
-
- val size_in_bytes : ('a, 'b, 'c) t -> int
- (** [size_in_bytes a] is the number of elements in [a]
- multiplied by [a]'s {!kind_size_in_bytes}.
-
- @since 4.03.0 *)
-
- external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3"
- (** [Array3.get a x y z], also written [a.{x,y,z}],
- returns the element of [a] at coordinates ([x], [y], [z]).
- [x], [y] and [z] must be within the bounds of [a],
- as described for {!Bigarray.Genarray.get};
- otherwise, [Invalid_argument] is raised. *)
-
- external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
- = "%caml_ba_set_3"
- (** [Array3.set a x y v], or alternatively [a.{x,y,z} <- v],
- stores the value [v] at coordinates ([x], [y], [z]) in [a].
- [x], [y] and [z] must be within the bounds of [a],
- as described for {!Bigarray.Genarray.set};
- otherwise, [Invalid_argument] is raised. *)
-
- external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
- = "caml_ba_sub"
- (** Extract a three-dimensional sub-array of the given
- three-dimensional big array by restricting the first dimension.
- See {!Bigarray.Genarray.sub_left} for more details. [Array3.sub_left]
- applies only to arrays with C layout. *)
-
- external sub_right:
- ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
- = "caml_ba_sub"
- (** Extract a three-dimensional sub-array of the given
- three-dimensional big array by restricting the second dimension.
- See {!Bigarray.Genarray.sub_right} for more details. [Array3.sub_right]
- applies only to arrays with Fortran layout. *)
-
- val slice_left_1:
- ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) Array1.t
- (** Extract a one-dimensional slice of the given three-dimensional
- big array by fixing the first two coordinates.
- The integer parameters are the coordinates of the slice to
- extract. See {!Bigarray.Genarray.slice_left} for more details.
- [Array3.slice_left_1] applies only to arrays with C layout. *)
-
- val slice_right_1:
- ('a, 'b, fortran_layout) t ->
- int -> int -> ('a, 'b, fortran_layout) Array1.t
- (** Extract a one-dimensional slice of the given three-dimensional
- big array by fixing the last two coordinates.
- The integer parameters are the coordinates of the slice to
- extract. See {!Bigarray.Genarray.slice_right} for more details.
- [Array3.slice_right_1] applies only to arrays with Fortran
- layout. *)
-
- val slice_left_2: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array2.t
- (** Extract a two-dimensional slice of the given three-dimensional
- big array by fixing the first coordinate.
- The integer parameter is the first coordinate of the slice to
- extract. See {!Bigarray.Genarray.slice_left} for more details.
- [Array3.slice_left_2] applies only to arrays with C layout. *)
-
- val slice_right_2:
- ('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array2.t
- (** Extract a two-dimensional slice of the given
- three-dimensional big array by fixing the last coordinate.
- The integer parameter is the coordinate of the slice
- to extract. See {!Bigarray.Genarray.slice_right} for more details.
- [Array3.slice_right_2] applies only to arrays with Fortran
- layout. *)
-
- external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
- = "caml_ba_blit"
- (** Copy the first big array to the second big array.
- See {!Bigarray.Genarray.blit} for more details. *)
-
- external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
- (** Fill the given big array with the given value.
- See {!Bigarray.Genarray.fill} for more details. *)
-
- val of_array:
- ('a, 'b) kind -> 'c layout -> 'a array array array -> ('a, 'b, 'c) t
- (** Build a three-dimensional big array initialized from the
- given array of arrays of arrays. *)
-
+module Array3 : sig
+ include module type of struct include Stdlib.Bigarray.Array3 end
val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout ->
bool -> int -> int -> int -> ('a, 'b, 'c) t
[@@ocaml.deprecated "\
Use [array3_of_genarray (Unix.map_file ...)] instead.\n\
Note that Bigarray.Array3.map_file raises Sys_error while\n\
Unix.map_file raises Unix_error."]
-
- external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a
- = "%caml_ba_unsafe_ref_3"
- (** Like {!Bigarray.Array3.get}, but bounds checking is not always
- performed. *)
-
- external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
- = "%caml_ba_unsafe_set_3"
- (** Like {!Bigarray.Array3.set}, but bounds checking is not always
- performed. *)
-
end
-
-(** {1 Coercions between generic big arrays and fixed-dimension big arrays} *)
-
-external genarray_of_array0 :
- ('a, 'b, 'c) Array0.t -> ('a, 'b, 'c) Genarray.t = "%identity"
-(** Return the generic big array corresponding to the given zero-dimensional
- big array. @since 4.05.0 *)
-
-external genarray_of_array1 :
- ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t = "%identity"
-(** Return the generic big array corresponding to the given one-dimensional
- big array. *)
-
-external genarray_of_array2 :
- ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t = "%identity"
-(** Return the generic big array corresponding to the given two-dimensional
- big array. *)
-
-external genarray_of_array3 :
- ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t = "%identity"
-(** Return the generic big array corresponding to the given three-dimensional
- big array. *)
-
-val array0_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array0.t
-(** Return the zero-dimensional big array corresponding to the given
- generic big array. Raise [Invalid_argument] if the generic big array
- does not have exactly zero dimension.
- @since 4.05.0 *)
-
-val array1_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array1.t
-(** Return the one-dimensional big array corresponding to the given
- generic big array. Raise [Invalid_argument] if the generic big array
- does not have exactly one dimension. *)
-
-val array2_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array2.t
-(** Return the two-dimensional big array corresponding to the given
- generic big array. Raise [Invalid_argument] if the generic big array
- does not have exactly two dimensions. *)
-
-val array3_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array3.t
-(** Return the three-dimensional big array corresponding to the given
- generic big array. Raise [Invalid_argument] if the generic big array
- does not have exactly three dimensions. *)
-
-
-(** {1 Re-shaping big arrays} *)
-
-val reshape : ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t
-(** [reshape b [|d1;...;dN|]] converts the big array [b] to a
- [N]-dimensional array of dimensions [d1]...[dN]. The returned
- array and the original array [b] share their data
- and have the same layout. For instance, assuming that [b]
- is a one-dimensional array of dimension 12, [reshape b [|3;4|]]
- returns a two-dimensional array [b'] of dimensions 3 and 4.
- If [b] has C layout, the element [(x,y)] of [b'] corresponds
- to the element [x * 3 + y] of [b]. If [b] has Fortran layout,
- the element [(x,y)] of [b'] corresponds to the element
- [x + (y - 1) * 4] of [b].
- The returned big array must have exactly the same number of
- elements as the original big array [b]. That is, the product
- of the dimensions of [b] must be equal to [i1 * ... * iN].
- Otherwise, [Invalid_argument] is raised. *)
-
-val reshape_0 : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array0.t
-(** Specialized version of {!Bigarray.reshape} for reshaping to
- zero-dimensional arrays.
- @since 4.05.0 *)
-
-val reshape_1 : ('a, 'b, 'c) Genarray.t -> int -> ('a, 'b, 'c) Array1.t
-(** Specialized version of {!Bigarray.reshape} for reshaping to
- one-dimensional arrays. *)
-
-val reshape_2 : ('a, 'b, 'c) Genarray.t -> int -> int -> ('a, 'b, 'c) Array2.t
-(** Specialized version of {!Bigarray.reshape} for reshaping to
- two-dimensional arrays. *)
-
-val reshape_3 :
- ('a, 'b, 'c) Genarray.t -> int -> int -> int -> ('a, 'b, 'c) Array3.t
-(** Specialized version of {!Bigarray.reshape} for reshaping to
- three-dimensional arrays. *)
+++ /dev/null
-/**************************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */
-/* */
-/* Copyright 2000 Institut National de Recherche en Informatique et */
-/* en Automatique. */
-/* */
-/* All rights reserved. This file is distributed under the terms of */
-/* the GNU Lesser General Public License version 2.1, with the */
-/* special exception on linking described in the file LICENSE. */
-/* */
-/**************************************************************************/
-
-#define CAML_INTERNALS
-
-#include <stddef.h>
-#include <stdarg.h>
-#include <string.h>
-#include "caml/alloc.h"
-#include "caml/bigarray.h"
-#include "caml/custom.h"
-#include "caml/fail.h"
-#include "caml/intext.h"
-#include "caml/hash.h"
-#include "caml/memory.h"
-#include "caml/mlvalues.h"
-#include "caml/signals.h"
-
-#define int8 caml_ba_int8
-#define uint8 caml_ba_uint8
-#define int16 caml_ba_int16
-#define uint16 caml_ba_uint16
-
-/* Allocate a bigarray from OCaml */
-
-CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim)
-{
- intnat dim[CAML_BA_MAX_NUM_DIMS];
- mlsize_t num_dims;
- int i, flags;
-
- num_dims = Wosize_val(vdim);
- /* here num_dims is unsigned (mlsize_t) so no need to check (num_dims >= 0) */
- if (num_dims > CAML_BA_MAX_NUM_DIMS)
- caml_invalid_argument("Bigarray.create: bad number of dimensions");
- for (i = 0; i < num_dims; i++) {
- dim[i] = Long_val(Field(vdim, i));
- if (dim[i] < 0)
- caml_invalid_argument("Bigarray.create: negative dimension");
- }
- flags = Caml_ba_kind_val(vkind) | Caml_ba_layout_val(vlayout);
- return caml_ba_alloc(flags, num_dims, NULL, dim);
-}
-
-/* Given a big array and a vector of indices, check that the indices
- are within the bounds and return the offset of the corresponding
- array element in the data part of the array. */
-
-static long caml_ba_offset(struct caml_ba_array * b, intnat * index)
-{
- intnat offset;
- int i;
-
- offset = 0;
- if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) {
- /* C-style layout: row major, indices start at 0 */
- for (i = 0; i < b->num_dims; i++) {
- if ((uintnat) index[i] >= (uintnat) b->dim[i])
- caml_array_bound_error();
- offset = offset * b->dim[i] + index[i];
- }
- } else {
- /* Fortran-style layout: column major, indices start at 1 */
- for (i = b->num_dims - 1; i >= 0; i--) {
- if ((uintnat) (index[i] - 1) >= (uintnat) b->dim[i])
- caml_array_bound_error();
- offset = offset * b->dim[i] + (index[i] - 1);
- }
- }
- return offset;
-}
-
-/* Helper function to allocate a record of two double floats */
-
-static value copy_two_doubles(double d0, double d1)
-{
- value res = caml_alloc_small(2 * Double_wosize, Double_array_tag);
- Store_double_field(res, 0, d0);
- Store_double_field(res, 1, d1);
- return res;
-}
-
-/* Generic code to read from a big array */
-
-value caml_ba_get_N(value vb, value * vind, int nind)
-{
- struct caml_ba_array * b = Caml_ba_array_val(vb);
- intnat index[CAML_BA_MAX_NUM_DIMS];
- int i;
- intnat offset;
-
- /* Check number of indices = number of dimensions of array
- (maybe not necessary if ML typing guarantees this) */
- if (nind != b->num_dims)
- caml_invalid_argument("Bigarray.get: wrong number of indices");
- /* Compute offset and check bounds */
- for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]);
- offset = caml_ba_offset(b, index);
- /* Perform read */
- switch ((b->flags) & CAML_BA_KIND_MASK) {
- default:
- CAMLassert(0);
- case CAML_BA_FLOAT32:
- return caml_copy_double(((float *) b->data)[offset]);
- case CAML_BA_FLOAT64:
- return caml_copy_double(((double *) b->data)[offset]);
- case CAML_BA_SINT8:
- return Val_int(((int8 *) b->data)[offset]);
- case CAML_BA_UINT8:
- return Val_int(((uint8 *) b->data)[offset]);
- case CAML_BA_SINT16:
- return Val_int(((int16 *) b->data)[offset]);
- case CAML_BA_UINT16:
- return Val_int(((uint16 *) b->data)[offset]);
- case CAML_BA_INT32:
- return caml_copy_int32(((int32_t *) b->data)[offset]);
- case CAML_BA_INT64:
- return caml_copy_int64(((int64_t *) b->data)[offset]);
- case CAML_BA_NATIVE_INT:
- return caml_copy_nativeint(((intnat *) b->data)[offset]);
- case CAML_BA_CAML_INT:
- return Val_long(((intnat *) b->data)[offset]);
- case CAML_BA_COMPLEX32:
- { float * p = ((float *) b->data) + offset * 2;
- return copy_two_doubles(p[0], p[1]); }
- case CAML_BA_COMPLEX64:
- { double * p = ((double *) b->data) + offset * 2;
- return copy_two_doubles(p[0], p[1]); }
- case CAML_BA_CHAR:
- return Val_int(((unsigned char *) b->data)[offset]);
- }
-}
-
-CAMLprim value caml_ba_get_1(value vb, value vind1)
-{
- return caml_ba_get_N(vb, &vind1, 1);
-}
-
-CAMLprim value caml_ba_get_2(value vb, value vind1, value vind2)
-{
- value vind[2];
- vind[0] = vind1; vind[1] = vind2;
- return caml_ba_get_N(vb, vind, 2);
-}
-
-CAMLprim value caml_ba_get_3(value vb, value vind1, value vind2, value vind3)
-{
- value vind[3];
- vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
- return caml_ba_get_N(vb, vind, 3);
-}
-
-#if 0
-CAMLprim value caml_ba_get_4(value vb, value vind1, value vind2,
- value vind3, value vind4)
-{
- value vind[4];
- vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4;
- return caml_ba_get_N(vb, vind, 4);
-}
-
-CAMLprim value caml_ba_get_5(value vb, value vind1, value vind2,
- value vind3, value vind4, value vind5)
-{
- value vind[5];
- vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
- vind[3] = vind4; vind[4] = vind5;
- return caml_ba_get_N(vb, vind, 5);
-}
-
-CAMLprim value caml_ba_get_6(value vb, value vind1, value vind2,
- value vind3, value vind4, value vind5, value vind6)
-{
- value vind[6];
- vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
- vind[3] = vind4; vind[4] = vind5; vind[5] = vind6;
- return caml_ba_get_N(vb, vind, 6);
-}
-#endif
-
-CAMLprim value caml_ba_get_generic(value vb, value vind)
-{
- return caml_ba_get_N(vb, &Field(vind, 0), Wosize_val(vind));
-}
-
-
-CAMLprim value caml_ba_uint8_get16(value vb, value vind)
-{
- intnat res;
- unsigned char b1, b2;
- intnat idx = Long_val(vind);
- struct caml_ba_array * b = Caml_ba_array_val(vb);
- if (idx < 0 || idx >= b->dim[0] - 1) caml_array_bound_error();
- b1 = ((unsigned char*) b->data)[idx];
- b2 = ((unsigned char*) b->data)[idx+1];
-#ifdef ARCH_BIG_ENDIAN
- res = b1 << 8 | b2;
-#else
- res = b2 << 8 | b1;
-#endif
- return Val_int(res);
-}
-
-CAMLprim value caml_ba_uint8_get32(value vb, value vind)
-{
- intnat res;
- unsigned char b1, b2, b3, b4;
- intnat idx = Long_val(vind);
- struct caml_ba_array * b = Caml_ba_array_val(vb);
- if (idx < 0 || idx >= b->dim[0] - 3) caml_array_bound_error();
- b1 = ((unsigned char*) b->data)[idx];
- b2 = ((unsigned char*) b->data)[idx+1];
- b3 = ((unsigned char*) b->data)[idx+2];
- b4 = ((unsigned char*) b->data)[idx+3];
-#ifdef ARCH_BIG_ENDIAN
- res = b1 << 24 | b2 << 16 | b3 << 8 | b4;
-#else
- res = b4 << 24 | b3 << 16 | b2 << 8 | b1;
-#endif
- return caml_copy_int32(res);
-}
-
-CAMLprim value caml_ba_uint8_get64(value vb, value vind)
-{
- uint64_t res;
- unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
- intnat idx = Long_val(vind);
- struct caml_ba_array * b = Caml_ba_array_val(vb);
- if (idx < 0 || idx >= b->dim[0] - 7) caml_array_bound_error();
- b1 = ((unsigned char*) b->data)[idx];
- b2 = ((unsigned char*) b->data)[idx+1];
- b3 = ((unsigned char*) b->data)[idx+2];
- b4 = ((unsigned char*) b->data)[idx+3];
- b5 = ((unsigned char*) b->data)[idx+4];
- b6 = ((unsigned char*) b->data)[idx+5];
- b7 = ((unsigned char*) b->data)[idx+6];
- b8 = ((unsigned char*) b->data)[idx+7];
-#ifdef ARCH_BIG_ENDIAN
- res = (uint64_t) b1 << 56 | (uint64_t) b2 << 48
- | (uint64_t) b3 << 40 | (uint64_t) b4 << 32
- | (uint64_t) b5 << 24 | (uint64_t) b6 << 16
- | (uint64_t) b7 << 8 | (uint64_t) b8;
-#else
- res = (uint64_t) b8 << 56 | (uint64_t) b7 << 48
- | (uint64_t) b6 << 40 | (uint64_t) b5 << 32
- | (uint64_t) b4 << 24 | (uint64_t) b3 << 16
- | (uint64_t) b2 << 8 | (uint64_t) b1;
-#endif
- return caml_copy_int64(res);
-}
-
-/* Generic write to a big array */
-
-static value caml_ba_set_aux(value vb, value * vind, intnat nind, value newval)
-{
- struct caml_ba_array * b = Caml_ba_array_val(vb);
- intnat index[CAML_BA_MAX_NUM_DIMS];
- int i;
- intnat offset;
-
- /* Check number of indices = number of dimensions of array
- (maybe not necessary if ML typing guarantees this) */
- if (nind != b->num_dims)
- caml_invalid_argument("Bigarray.set: wrong number of indices");
- /* Compute offset and check bounds */
- for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]);
- offset = caml_ba_offset(b, index);
- /* Perform write */
- switch (b->flags & CAML_BA_KIND_MASK) {
- default:
- CAMLassert(0);
- case CAML_BA_FLOAT32:
- ((float *) b->data)[offset] = Double_val(newval); break;
- case CAML_BA_FLOAT64:
- ((double *) b->data)[offset] = Double_val(newval); break;
- case CAML_BA_CHAR:
- case CAML_BA_SINT8:
- case CAML_BA_UINT8:
- ((int8 *) b->data)[offset] = Int_val(newval); break;
- case CAML_BA_SINT16:
- case CAML_BA_UINT16:
- ((int16 *) b->data)[offset] = Int_val(newval); break;
- case CAML_BA_INT32:
- ((int32_t *) b->data)[offset] = Int32_val(newval); break;
- case CAML_BA_INT64:
- ((int64_t *) b->data)[offset] = Int64_val(newval); break;
- case CAML_BA_NATIVE_INT:
- ((intnat *) b->data)[offset] = Nativeint_val(newval); break;
- case CAML_BA_CAML_INT:
- ((intnat *) b->data)[offset] = Long_val(newval); break;
- case CAML_BA_COMPLEX32:
- { float * p = ((float *) b->data) + offset * 2;
- p[0] = Double_field(newval, 0);
- p[1] = Double_field(newval, 1);
- break; }
- case CAML_BA_COMPLEX64:
- { double * p = ((double *) b->data) + offset * 2;
- p[0] = Double_field(newval, 0);
- p[1] = Double_field(newval, 1);
- break; }
- }
- return Val_unit;
-}
-
-CAMLprim value caml_ba_set_1(value vb, value vind1, value newval)
-{
- return caml_ba_set_aux(vb, &vind1, 1, newval);
-}
-
-CAMLprim value caml_ba_set_2(value vb, value vind1, value vind2, value newval)
-{
- value vind[2];
- vind[0] = vind1; vind[1] = vind2;
- return caml_ba_set_aux(vb, vind, 2, newval);
-}
-
-CAMLprim value caml_ba_set_3(value vb, value vind1, value vind2, value vind3,
- value newval)
-{
- value vind[3];
- vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
- return caml_ba_set_aux(vb, vind, 3, newval);
-}
-
-#if 0
-CAMLprim value caml_ba_set_4(value vb, value vind1, value vind2,
- value vind3, value vind4, value newval)
-{
- value vind[4];
- vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4;
- return caml_ba_set_aux(vb, vind, 4, newval);
-}
-
-CAMLprim value caml_ba_set_5(value vb, value vind1, value vind2,
- value vind3, value vind4, value vind5, value newval)
-{
- value vind[5];
- vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
- vind[3] = vind4; vind[4] = vind5;
- return caml_ba_set_aux(vb, vind, 5, newval);
-}
-
-CAMLprim value caml_ba_set_6(value vb, value vind1, value vind2,
- value vind3, value vind4, value vind5,
- value vind6, value newval)
-{
- value vind[6];
- vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
- vind[3] = vind4; vind[4] = vind5; vind[5] = vind6;
- return caml_ba_set_aux(vb, vind, 6, newval);
-}
-
-value caml_ba_set_N(value vb, value * vind, int nargs)
-{
- return caml_ba_set_aux(vb, vind, nargs - 1, vind[nargs - 1]);
-}
-#endif
-
-CAMLprim value caml_ba_set_generic(value vb, value vind, value newval)
-{
- return caml_ba_set_aux(vb, &Field(vind, 0), Wosize_val(vind), newval);
-}
-
-CAMLprim value caml_ba_uint8_set16(value vb, value vind, value newval)
-{
- unsigned char b1, b2;
- intnat val;
- intnat idx = Long_val(vind);
- struct caml_ba_array * b = Caml_ba_array_val(vb);
- if (idx < 0 || idx >= b->dim[0] - 1) caml_array_bound_error();
- val = Long_val(newval);
-#ifdef ARCH_BIG_ENDIAN
- b1 = 0xFF & val >> 8;
- b2 = 0xFF & val;
-#else
- b2 = 0xFF & val >> 8;
- b1 = 0xFF & val;
-#endif
- ((unsigned char*) b->data)[idx] = b1;
- ((unsigned char*) b->data)[idx+1] = b2;
- return Val_unit;
-}
-
-CAMLprim value caml_ba_uint8_set32(value vb, value vind, value newval)
-{
- unsigned char b1, b2, b3, b4;
- intnat idx = Long_val(vind);
- intnat val;
- struct caml_ba_array * b = Caml_ba_array_val(vb);
- if (idx < 0 || idx >= b->dim[0] - 3) caml_array_bound_error();
- val = Int32_val(newval);
-#ifdef ARCH_BIG_ENDIAN
- b1 = 0xFF & val >> 24;
- b2 = 0xFF & val >> 16;
- b3 = 0xFF & val >> 8;
- b4 = 0xFF & val;
-#else
- b4 = 0xFF & val >> 24;
- b3 = 0xFF & val >> 16;
- b2 = 0xFF & val >> 8;
- b1 = 0xFF & val;
-#endif
- ((unsigned char*) b->data)[idx] = b1;
- ((unsigned char*) b->data)[idx+1] = b2;
- ((unsigned char*) b->data)[idx+2] = b3;
- ((unsigned char*) b->data)[idx+3] = b4;
- return Val_unit;
-}
-
-CAMLprim value caml_ba_uint8_set64(value vb, value vind, value newval)
-{
- unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
- intnat idx = Long_val(vind);
- int64_t val;
- struct caml_ba_array * b = Caml_ba_array_val(vb);
- if (idx < 0 || idx >= b->dim[0] - 7) caml_array_bound_error();
- val = Int64_val(newval);
-#ifdef ARCH_BIG_ENDIAN
- b1 = 0xFF & val >> 56;
- b2 = 0xFF & val >> 48;
- b3 = 0xFF & val >> 40;
- b4 = 0xFF & val >> 32;
- b5 = 0xFF & val >> 24;
- b6 = 0xFF & val >> 16;
- b7 = 0xFF & val >> 8;
- b8 = 0xFF & val;
-#else
- b8 = 0xFF & val >> 56;
- b7 = 0xFF & val >> 48;
- b6 = 0xFF & val >> 40;
- b5 = 0xFF & val >> 32;
- b4 = 0xFF & val >> 24;
- b3 = 0xFF & val >> 16;
- b2 = 0xFF & val >> 8;
- b1 = 0xFF & val;
-#endif
- ((unsigned char*) b->data)[idx] = b1;
- ((unsigned char*) b->data)[idx+1] = b2;
- ((unsigned char*) b->data)[idx+2] = b3;
- ((unsigned char*) b->data)[idx+3] = b4;
- ((unsigned char*) b->data)[idx+4] = b5;
- ((unsigned char*) b->data)[idx+5] = b6;
- ((unsigned char*) b->data)[idx+6] = b7;
- ((unsigned char*) b->data)[idx+7] = b8;
- return Val_unit;
-}
-
-/* Return the number of dimensions of a big array */
-
-CAMLprim value caml_ba_num_dims(value vb)
-{
- struct caml_ba_array * b = Caml_ba_array_val(vb);
- return Val_long(b->num_dims);
-}
-
-/* Return the n-th dimension of a big array */
-
-CAMLprim value caml_ba_dim(value vb, value vn)
-{
- struct caml_ba_array * b = Caml_ba_array_val(vb);
- intnat n = Long_val(vn);
- if (n < 0 || n >= b->num_dims) caml_invalid_argument("Bigarray.dim");
- return Val_long(b->dim[n]);
-}
-
-CAMLprim value caml_ba_dim_1(value vb)
-{
- return caml_ba_dim(vb, Val_int(0));
-}
-
-CAMLprim value caml_ba_dim_2(value vb)
-{
- return caml_ba_dim(vb, Val_int(1));
-}
-
-CAMLprim value caml_ba_dim_3(value vb)
-{
- return caml_ba_dim(vb, Val_int(2));
-}
-
-/* Return the kind of a big array */
-
-CAMLprim value caml_ba_kind(value vb)
-{
- return Val_caml_ba_kind(Caml_ba_array_val(vb)->flags & CAML_BA_KIND_MASK);
-}
-
-/* Return the layout of a big array */
-
-CAMLprim value caml_ba_layout(value vb)
-{
- int layout = Caml_ba_array_val(vb)->flags & CAML_BA_LAYOUT_MASK;
- return Val_caml_ba_layout(layout);
-}
-
-/* Create / update proxy to indicate that b2 is a sub-array of b1 */
-
-static void caml_ba_update_proxy(struct caml_ba_array * b1,
- struct caml_ba_array * b2)
-{
- struct caml_ba_proxy * proxy;
- /* Nothing to do for un-managed arrays */
- if ((b1->flags & CAML_BA_MANAGED_MASK) == CAML_BA_EXTERNAL) return;
- if (b1->proxy != NULL) {
- /* If b1 is already a proxy for a larger array, increment refcount of
- proxy */
- b2->proxy = b1->proxy;
- ++ b1->proxy->refcount;
- } else {
- /* Otherwise, create proxy and attach it to both b1 and b2 */
- proxy = malloc(sizeof(struct caml_ba_proxy));
- if (proxy == NULL) caml_raise_out_of_memory();
- proxy->refcount = 2; /* original array + sub array */
- proxy->data = b1->data;
- proxy->size =
- b1->flags & CAML_BA_MAPPED_FILE ? caml_ba_byte_size(b1) : 0;
- b1->proxy = proxy;
- b2->proxy = proxy;
- }
-}
-
-/* Slicing */
-
-CAMLprim value caml_ba_slice(value vb, value vind)
-{
- CAMLparam2 (vb, vind);
- #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
- CAMLlocal1 (res);
- intnat index[CAML_BA_MAX_NUM_DIMS];
- int num_inds, i;
- intnat offset;
- intnat * sub_dims;
- char * sub_data;
-
- /* Check number of indices <= number of dimensions of array */
- num_inds = Wosize_val(vind);
- if (num_inds > b->num_dims)
- caml_invalid_argument("Bigarray.slice: too many indices");
- /* Compute offset and check bounds */
- if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) {
- /* We slice from the left */
- for (i = 0; i < num_inds; i++) index[i] = Long_val(Field(vind, i));
- for (/*nothing*/; i < b->num_dims; i++) index[i] = 0;
- offset = caml_ba_offset(b, index);
- sub_dims = b->dim + num_inds;
- } else {
- /* We slice from the right */
- for (i = 0; i < num_inds; i++)
- index[b->num_dims - num_inds + i] = Long_val(Field(vind, i));
- for (i = 0; i < b->num_dims - num_inds; i++) index[i] = 1;
- offset = caml_ba_offset(b, index);
- sub_dims = b->dim;
- }
- sub_data =
- (char *) b->data +
- offset * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
- /* Allocate an OCaml bigarray to hold the result */
- res = caml_ba_alloc(b->flags, b->num_dims - num_inds, sub_data, sub_dims);
- /* Create or update proxy in case of managed bigarray */
- caml_ba_update_proxy(b, Caml_ba_array_val(res));
- /* Return result */
- CAMLreturn (res);
-
- #undef b
-}
-
-/* Changing the layout of an array (memory is shared) */
-
-CAMLprim value caml_ba_change_layout(value vb, value vlayout)
-{
- CAMLparam2 (vb, vlayout);
- CAMLlocal1 (res);
- #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
- /* if the layout is different, change the flags and reverse the dimensions */
- if (Caml_ba_layout_val(vlayout) != (b->flags & CAML_BA_LAYOUT_MASK)) {
- /* change the flags to reflect the new layout */
- int flags = (b->flags & (CAML_BA_KIND_MASK | CAML_BA_MANAGED_MASK))
- | Caml_ba_layout_val(vlayout);
- /* reverse the dimensions */
- intnat new_dim[CAML_BA_MAX_NUM_DIMS];
- unsigned int i;
- for(i = 0; i < b->num_dims; i++) new_dim[i] = b->dim[b->num_dims - i - 1];
- res = caml_ba_alloc(flags, b->num_dims, b->data, new_dim);
- caml_ba_update_proxy(b, Caml_ba_array_val(res));
- CAMLreturn(res);
- } else {
- /* otherwise, do nothing */
- CAMLreturn(vb);
- }
- #undef b
-}
-
-
-/* Extracting a sub-array of same number of dimensions */
-
-CAMLprim value caml_ba_sub(value vb, value vofs, value vlen)
-{
- CAMLparam3 (vb, vofs, vlen);
- CAMLlocal1 (res);
- #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
- intnat ofs = Long_val(vofs);
- intnat len = Long_val(vlen);
- int i, changed_dim;
- intnat mul;
- char * sub_data;
-
- /* Compute offset and check bounds */
- if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) {
- /* We reduce the first dimension */
- mul = 1;
- for (i = 1; i < b->num_dims; i++) mul *= b->dim[i];
- changed_dim = 0;
- } else {
- /* We reduce the last dimension */
- mul = 1;
- for (i = 0; i < b->num_dims - 1; i++) mul *= b->dim[i];
- changed_dim = b->num_dims - 1;
- ofs--; /* Fortran arrays start at 1 */
- }
- if (ofs < 0 || len < 0 || ofs + len > b->dim[changed_dim])
- caml_invalid_argument("Bigarray.sub: bad sub-array");
- sub_data =
- (char *) b->data +
- ofs * mul * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
- /* Allocate an OCaml bigarray to hold the result */
- res = caml_ba_alloc(b->flags, b->num_dims, sub_data, b->dim);
- /* Doctor the changed dimension */
- Caml_ba_array_val(res)->dim[changed_dim] = len;
- /* Create or update proxy in case of managed bigarray */
- caml_ba_update_proxy(b, Caml_ba_array_val(res));
- /* Return result */
- CAMLreturn (res);
-
- #undef b
-}
-
-/* Copying a big array into another one */
-
-#define LEAVE_RUNTIME_OP_CUTOFF 4096
-#define is_mmapped(ba) ((ba)->flags & CAML_BA_MAPPED_FILE)
-
-CAMLprim value caml_ba_blit(value vsrc, value vdst)
-{
- CAMLparam2(vsrc, vdst);
- struct caml_ba_array * src = Caml_ba_array_val(vsrc);
- struct caml_ba_array * dst = Caml_ba_array_val(vdst);
- void *src_data = src->data;
- void *dst_data = dst->data;
- int i;
- intnat num_bytes;
- int leave_runtime;
-
- /* Check same numbers of dimensions and same dimensions */
- if (src->num_dims != dst->num_dims) goto blit_error;
- for (i = 0; i < src->num_dims; i++)
- if (src->dim[i] != dst->dim[i]) goto blit_error;
- /* Compute number of bytes in array data */
- num_bytes =
- caml_ba_num_elts(src)
- * caml_ba_element_size[src->flags & CAML_BA_KIND_MASK];
- leave_runtime =
- (
- (num_bytes >= LEAVE_RUNTIME_OP_CUTOFF*sizeof(long))
- || is_mmapped(src)
- || is_mmapped(dst)
- );
- /* Do the copying */
- if (leave_runtime) caml_enter_blocking_section();
- memmove (dst_data, src_data, num_bytes);
- if (leave_runtime) caml_leave_blocking_section();
- CAMLreturn (Val_unit);
- blit_error:
- caml_invalid_argument("Bigarray.blit: dimension mismatch");
- CAMLreturn (Val_unit); /* not reached */
-}
-
-/* Filling a big array with a given value */
-
-#define FILL_GEN_LOOP(n_ops, loop) do{ \
- int leave_runtime = ((n_ops >= LEAVE_RUNTIME_OP_CUTOFF) || is_mmapped(b)); \
- if (leave_runtime) caml_enter_blocking_section(); \
- loop; \
- if (leave_runtime) caml_leave_blocking_section(); \
-}while(0)
-
-#define FILL_SCALAR_LOOP \
- FILL_GEN_LOOP(num_elts, \
- for (p = data; num_elts > 0; p++, num_elts--) *p = init)
-
-#define FILL_COMPLEX_LOOP \
- FILL_GEN_LOOP(num_elts + num_elts, \
- for (p = data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; })
-
-CAMLprim value caml_ba_fill(value vb, value vinit)
-{
- CAMLparam1(vb);
- struct caml_ba_array * b = Caml_ba_array_val(vb);
- void *data = b->data;
- intnat num_elts = caml_ba_num_elts(b);
-
- switch (b->flags & CAML_BA_KIND_MASK) {
- default:
- CAMLassert(0);
- case CAML_BA_FLOAT32: {
- float init = Double_val(vinit);
- float * p;
- FILL_SCALAR_LOOP;
- break;
- }
- case CAML_BA_FLOAT64: {
- double init = Double_val(vinit);
- double * p;
- FILL_SCALAR_LOOP;
- break;
- }
- case CAML_BA_CHAR:
- case CAML_BA_SINT8:
- case CAML_BA_UINT8: {
- int init = Int_val(vinit);
- unsigned char * p;
- FILL_SCALAR_LOOP;
- break;
- }
- case CAML_BA_SINT16:
- case CAML_BA_UINT16: {
- int init = Int_val(vinit);
- int16 * p;
- FILL_SCALAR_LOOP;
- break;
- }
- case CAML_BA_INT32: {
- int32_t init = Int32_val(vinit);
- int32_t * p;
- FILL_SCALAR_LOOP;
- break;
- }
- case CAML_BA_INT64: {
- int64_t init = Int64_val(vinit);
- int64_t * p;
- FILL_SCALAR_LOOP;
- break;
- }
- case CAML_BA_NATIVE_INT: {
- intnat init = Nativeint_val(vinit);
- intnat * p;
- FILL_SCALAR_LOOP;
- break;
- }
- case CAML_BA_CAML_INT: {
- intnat init = Long_val(vinit);
- intnat * p;
- FILL_SCALAR_LOOP;
- break;
- }
- case CAML_BA_COMPLEX32: {
- float init0 = Double_field(vinit, 0);
- float init1 = Double_field(vinit, 1);
- float * p;
- FILL_COMPLEX_LOOP;
- break;
- }
- case CAML_BA_COMPLEX64: {
- double init0 = Double_field(vinit, 0);
- double init1 = Double_field(vinit, 1);
- double * p;
- FILL_COMPLEX_LOOP;
- break;
- }
- }
- CAMLreturn (Val_unit);
-}
-
-/* Reshape an array: change dimensions and number of dimensions, preserving
- array contents */
-
-CAMLprim value caml_ba_reshape(value vb, value vdim)
-{
- CAMLparam2 (vb, vdim);
- CAMLlocal1 (res);
-#define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
- intnat dim[CAML_BA_MAX_NUM_DIMS];
- mlsize_t num_dims;
- uintnat num_elts;
- int i;
-
- num_dims = Wosize_val(vdim);
- /* here num_dims is unsigned (mlsize_t) so no need to check (num_dims >= 0) */
- if (num_dims > CAML_BA_MAX_NUM_DIMS)
- caml_invalid_argument("Bigarray.reshape: bad number of dimensions");
- num_elts = 1;
- for (i = 0; i < num_dims; i++) {
- dim[i] = Long_val(Field(vdim, i));
- if (dim[i] < 0)
- caml_invalid_argument("Bigarray.reshape: negative dimension");
- num_elts *= dim[i];
- }
- /* Check that sizes agree */
- if (num_elts != caml_ba_num_elts(b))
- caml_invalid_argument("Bigarray.reshape: size mismatch");
- /* Create bigarray with same data and new dimensions */
- res = caml_ba_alloc(b->flags, num_dims, b->data, dim);
- /* Create or update proxy in case of managed bigarray */
- caml_ba_update_proxy(b, Caml_ba_array_val(res));
- /* Return result */
- CAMLreturn (res);
-
-#undef b
-}
# FIXME reduce redundancy by including ../Makefile
include ../../config/Makefile
+include ../../Makefile.common
+
CAMLRUN ?= ../../boot/ocamlrun
CAMLYACC ?= ../../boot/ocamlyacc
../../utils/arg_helper.cmo ../../utils/clflags.cmo \
../../utils/tbl.cmo ../../utils/consistbl.cmo \
../../utils/terminfo.cmo ../../utils/warnings.cmo \
+ ../../utils/build_path_prefix_map.cmo \
../../parsing/asttypes.cmi \
../../parsing/location.cmo ../../parsing/longident.cmo \
../../parsing/docstrings.cmo ../../parsing/syntaxerr.cmo \
extract_crc: dynlink.cma extract_crc.cmo
$(OCAMLC) -o extract_crc dynlink.cma extract_crc.cmo
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-
install:
- cp dynlink.cmi dynlink.cmti dynlink.cma dynlink.mli "$(INSTALL_LIBDIR)"
- cp extract_crc "$(INSTALL_LIBDIR)/extract_crc$(EXE)"
+ $(INSTALL_DATA) \
+ dynlink.cmi dynlink.cmti dynlink.cma dynlink.mli \
+ "$(INSTALL_LIBDIR)"
+ $(INSTALL_PROG) \
+ extract_crc "$(INSTALL_LIBDIR)/extract_crc$(EXE)"
installopt:
if $(NATDYNLINK); then \
- cp $(NATOBJS) dynlink.cmxa dynlink.$(A) "$(INSTALL_LIBDIR)" && \
+ $(INSTALL_DATA) \
+ $(NATOBJS) dynlink.cmxa dynlink.$(A) \
+ "$(INSTALL_LIBDIR)" && \
cd "$(INSTALL_LIBDIR)" && $(RANLIB) dynlink.$(A); \
fi
exception Error of error
(* Copied from config.ml to avoid dependencies *)
-let cmxs_magic_number = "Caml1999D022"
+let cmxs_magic_number = "Caml1999D023"
let dll_filename fname =
if Filename.is_implicit fname then Filename.concat (Sys.getcwd ()) fname
+spacetime_offline.$(O): spacetime_offline.c ../../byterun/caml/alloc.h \
+ ../../byterun/caml/misc.h ../../byterun/caml/config.h \
+ ../../byterun/caml/m.h ../../byterun/caml/s.h \
+ ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h \
+ ../../byterun/caml/gc.h ../../byterun/caml/intext.h \
+ ../../byterun/caml/io.h ../../byterun/caml/major_gc.h \
+ ../../byterun/caml/freelist.h ../../byterun/caml/memory.h \
+ ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
+ ../../byterun/caml/roots.h ../../byterun/caml/signals.h \
+ ../../byterun/caml/stack.h ../../byterun/caml/sys.h \
+ ../../byterun/caml/spacetime.h
raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
raw_spacetime_lib.cmi :
# Makefile for Raw_spacetime_lib
-ROOTDIR=../..
-include $(ROOTDIR)/config/Makefile
-
-CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
-CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib
-CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib \
- -I $(ROOTDIR)/stdlib
-
-# The remainder of this file could probably be simplified by including
-# ../Makefile.
-
LIBNAME=raw_spacetime_lib
+COBJS=spacetime_offline.$(O)
CAMLOBJS=raw_spacetime_lib.cmo
-COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g -safe-string $(EXTRACAMLFLAGS)
-
-CMIFILES=$(CAMLOBJS:.cmo=.cmi)
-CAMLOBJS_NAT=$(CAMLOBJS:.cmo=.cmx)
-
-all: $(LIBNAME).cma $(CMIFILES)
-
-allopt: $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES)
-
-$(LIBNAME).cma: $(CAMLOBJS)
- $(CAMLC) -a -o $(LIBNAME).cma -linkall $(CAMLOBJS)
-
-$(LIBNAME).cmxa: $(CAMLOBJS_NAT)
- $(CAMLOPT) -a -o $(LIBNAME).cmxa -linkall $(CAMLOBJS_NAT)
-
-$(LIBNAME).cmxs: $(LIBNAME).cmxa
- $(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa
-
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-
-install::
- cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) $(INSTALL_LIBDIR)
-
-installopt:
- cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) $(INSTALL_LIBDIR)/
- if test -f $(LIBNAME).cmxs; then \
- cp $(LIBNAME).cmxs $(INSTALL_LIBDIR)/; \
- fi
-
-partialclean:
- rm -f *.cm*
-
-clean:: partialclean
- rm -f *.a *.o
-
-.SUFFIXES: .ml .mli .cmi .cmo .cmx
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
+include ../Makefile
+.PHONY: depend
depend:
- $(CAMLRUN) $(ROOTDIR)/tools/ocamldep *.mli *.ml > .depend
+ifeq "$(TOOLCHAIN)" "msvc"
+ $(error Dependencies cannot be regenerated using the MSVC ports)
+else
+ $(CC) -MM $(CPPFLAGS) *.c | sed -e 's/\.o/.$$(O)/g' > .depend
+ $(CAMLRUN) $(ROOTDIR)/tools/ocamldep -slash *.mli *.ml >> .depend
+endif
include .depend
(* This function unmarshals into malloc blocks, which mean that we
obtain a straightforward means of writing [compare] on [node]s. *)
external unmarshal : in_channel -> 'a
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_unmarshal_trie"
+ = "caml_spacetime_unmarshal_trie"
let unmarshal in_channel =
let trace = unmarshal in_channel in
else
Some ((Obj.magic trace) : node)
- let node_is_null (node : node) =
- ((Obj.magic node) : unit) == ()
-
let foreign_node_is_null (node : foreign_node) =
((Obj.magic node) : unit) == ()
external node_num_header_words : unit -> int
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_node_num_header_words" "noalloc"
+ = "caml_spacetime_node_num_header_words" [@@noalloc]
let num_header_words = lazy (node_num_header_words ())
| _ -> assert false
external annotation : ocaml_node -> int -> Annotation.t
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_ocaml_allocation_point_annotation"
- "noalloc"
+ = "caml_spacetime_ocaml_allocation_point_annotation"
+ [@@noalloc]
let annotation t = annotation t.node t.offset
external count : ocaml_node -> int -> int
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_ocaml_allocation_point_count"
- "noalloc"
+ = "caml_spacetime_ocaml_allocation_point_count"
+ [@@noalloc]
let num_words_including_headers t = count t.node t.offset
end
| _ -> assert false
external callee_node : ocaml_node -> int -> 'target
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_ocaml_direct_call_point_callee_node"
+ = "caml_spacetime_ocaml_direct_call_point_callee_node"
let callee_node (type target) (t : target t) : target =
callee_node t.node t.offset
external call_count : ocaml_node -> int -> int
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_ocaml_direct_call_point_call_count"
+ = "caml_spacetime_ocaml_direct_call_point_call_count"
let call_count t =
if Shape_table.call_counts t.shape_table then
(* CR-soon mshinwell: maybe rename ...c_node_call_site -> c_node_pc,
since it isn't a call site in this case. *)
external callee : foreign_node -> Function_entry_point.t
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_c_node_call_site"
+ = "caml_spacetime_c_node_call_site"
let callee t = callee t.node
(* This can return a node satisfying "is_null" in the case of an
uninitialised tail call point. See the comment in the C code. *)
external callee_node : foreign_node -> node
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_c_node_callee_node" "noalloc"
+ = "caml_spacetime_c_node_callee_node" [@@noalloc]
let callee_node t = callee_node t.node
external call_count : foreign_node -> int
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_c_node_call_count"
+ = "caml_spacetime_c_node_call_count"
let call_count t =
if t.call_counts then Some (call_count t.node)
else None
external next : foreign_node -> foreign_node
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_c_node_next" "noalloc"
+ = "caml_spacetime_c_node_next" [@@noalloc]
let next t =
let next = { t with node = next t.node; } in
end
external callees : ocaml_node -> int -> foreign_node
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_ocaml_indirect_call_point_callees"
- "noalloc"
+ = "caml_spacetime_ocaml_indirect_call_point_callees"
+ [@@noalloc]
let callees t =
let callees =
| Indirect_call of Indirect_call_point.t
external classify_direct_call_point : ocaml_node -> int -> int
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_classify_direct_call_point"
- "noalloc"
+ = "caml_spacetime_classify_direct_call_point"
+ [@@noalloc]
let classify t =
match t.part_of_shape with
- | Shape_table.Direct_call callee ->
+ | Shape_table.Direct_call _callee ->
let direct_call_point =
match classify_direct_call_point t.node t.offset with
| 0 ->
type t = ocaml_node
external function_identifier : t -> Function_identifier.t
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_ocaml_function_identifier"
+ = "caml_spacetime_ocaml_function_identifier"
external next_in_tail_call_chain : t -> t
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_ocaml_tail_chain" "noalloc"
+ = "caml_spacetime_ocaml_tail_chain" [@@noalloc]
external compare : t -> t -> int
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_compare_node" "noalloc"
+ = "caml_spacetime_compare_node" [@@noalloc]
let fields t ~shape_table =
let id = function_identifier t in
type t = foreign_node
external compare : t -> t -> int
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_compare_node" "noalloc"
+ = "caml_spacetime_compare_node" [@@noalloc]
let fields t =
if foreign_node_is_null t then None
external program_counter : t -> Program_counter.Foreign.t
(* This is not a mistake; the same C function works. *)
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_c_node_call_site"
+ = "caml_spacetime_c_node_call_site"
external annotation : t -> Annotation.t
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_c_node_profinfo" "noalloc"
+ = "caml_spacetime_c_node_profinfo" [@@noalloc]
external num_words_including_headers : t -> int
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_c_node_allocation_count" "noalloc"
+ = "caml_spacetime_c_node_allocation_count" [@@noalloc]
end
module Call_point = struct
type t = foreign_node
external call_site : t -> Program_counter.Foreign.t
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_c_node_call_site"
+ = "caml_spacetime_c_node_call_site"
(* May return a null node. See comment above and the C code. *)
external callee_node : t -> node
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_c_node_callee_node" "noalloc"
+ = "caml_spacetime_c_node_callee_node" [@@noalloc]
end
module Field = struct
| Call of Call_point.t
external is_call : t -> bool
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_c_node_is_call" "noalloc"
+ = "caml_spacetime_c_node_is_call" [@@noalloc]
let classify t =
if is_call t then Call t
else Allocation t
external next : t -> t
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_c_node_next" "noalloc"
+ = "caml_spacetime_c_node_next" [@@noalloc]
let next t =
let next = next t in
type t = node
external compare : t -> t -> int
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_compare_node" "noalloc"
+ = "caml_spacetime_compare_node" [@@noalloc]
end
include T
| OCaml of OCaml.Node.t
| Foreign of Foreign.Node.t
- (* CR-soon lwhite: These functions should work in bytecode *)
external is_ocaml_node : t -> bool
- = "caml_spacetime_only_works_for_native_code"
- "caml_spacetime_is_ocaml_node" "noalloc"
+ = "caml_spacetime_is_ocaml_node" [@@noalloc]
let classify t =
if is_ocaml_node t then OCaml ((Obj.magic t) : ocaml_node)
call_counts : bool;
}
- let pathname_suffix_trace = "trace"
-
(* The order of these constructors must match the C code. *)
type what_comes_next =
| Snapshot
(Array.of_list (List.rev snapshots)), List.rev events
let read ~path =
- let chn = open_in path in
+ let chn = open_in_bin path in
let magic_number : int = Marshal.from_channel chn in
let magic_number_base = magic_number land 0xffff_ffff in
let version_number = (magic_number lsr 32) land 0xffff in
val num_words_including_headers : t -> int
val next : t -> t option
end
+
(** Total allocations across *all threads*. *)
(* CR-someday mshinwell: change the relevant variables to be thread-local *)
val total_allocations : t -> Total_allocation.t option
--- /dev/null
+/**************************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Mark Shinwell and Leo White, Jane Street Europe */
+/* */
+/* Copyright 2013--2016, Jane Street Group, LLC */
+/* */
+/* All rights reserved. This file is distributed under the terms of */
+/* the GNU Lesser General Public License version 2.1, with the */
+/* special exception on linking described in the file LICENSE. */
+/* */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include <math.h>
+
+#include "caml/alloc.h"
+#include "caml/config.h"
+#include "caml/fail.h"
+#include "caml/gc.h"
+#include "caml/intext.h"
+#include "caml/major_gc.h"
+#include "caml/memory.h"
+#include "caml/minor_gc.h"
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/roots.h"
+#include "caml/signals.h"
+#include "caml/stack.h"
+#include "caml/sys.h"
+#include "caml/spacetime.h"
+
+#include "caml/s.h"
+
+#define SPACETIME_PROFINFO_WIDTH 26
+#define Spacetime_profinfo_hd(hd) \
+ (Gen_profinfo_hd(SPACETIME_PROFINFO_WIDTH, hd))
+
+#ifdef ARCH_SIXTYFOUR
+
+/* CR-someday lwhite: The following two definitions are copied from spacetime.c
+ because they are needed here, but must be inlined in spacetime.c
+ for performance. Perhaps a macro or "static inline" would be
+ more appropriate. */
+
+c_node* caml_spacetime_offline_c_node_of_stored_pointer_not_null
+ (value node_stored)
+{
+ CAMLassert(Is_c_node(node_stored));
+ return (c_node*) Hp_val(node_stored);
+}
+
+c_node_type caml_spacetime_offline_classify_c_node(c_node* node)
+{
+ return (node->pc & 2) ? CALL : ALLOCATION;
+}
+
+CAMLprim value caml_spacetime_compare_node(
+ value node1, value node2)
+{
+ CAMLassert(!Is_in_value_area(node1));
+ CAMLassert(!Is_in_value_area(node2));
+
+ if (node1 == node2) {
+ return Val_long(0);
+ }
+ if (node1 < node2) {
+ return Val_long(-1);
+ }
+ return Val_long(1);
+}
+
+CAMLprim value caml_spacetime_unmarshal_trie (value v_channel)
+{
+ return caml_input_value_to_outside_heap(v_channel);
+}
+
+CAMLprim value caml_spacetime_node_num_header_words(value unit)
+{
+ unit = Val_unit;
+ return Val_long(Node_num_header_words);
+}
+
+CAMLprim value caml_spacetime_is_ocaml_node(value node)
+{
+ CAMLassert(Is_ocaml_node(node) || Is_c_node(node));
+ return Val_bool(Is_ocaml_node(node));
+}
+
+CAMLprim value caml_spacetime_ocaml_function_identifier(value node)
+{
+ CAMLassert(Is_ocaml_node(node));
+ return caml_copy_int64((uint64_t) Decode_node_pc(Node_pc(node)));
+}
+
+CAMLprim value caml_spacetime_ocaml_tail_chain(value node)
+{
+ CAMLassert(Is_ocaml_node(node));
+ return Tail_link(node);
+}
+
+CAMLprim value caml_spacetime_classify_direct_call_point
+ (value node, value offset)
+{
+ uintnat field;
+ value callee_node;
+
+ CAMLassert(Is_ocaml_node(node));
+
+ field = Long_val(offset);
+
+ callee_node = Direct_callee_node(node, field);
+ if (!Is_block(callee_node)) {
+ /* An unused call point (may be a tail call point). */
+ return Val_long(0);
+ } else if (Is_ocaml_node(callee_node)) {
+ return Val_long(1); /* direct call point to OCaml code */
+ } else {
+ return Val_long(2); /* direct call point to non-OCaml code */
+ }
+}
+
+CAMLprim value caml_spacetime_ocaml_allocation_point_annotation
+ (value node, value offset)
+{
+ uintnat profinfo_shifted;
+ profinfo_shifted = (uintnat) Alloc_point_profinfo(node, Long_val(offset));
+ return Val_long(Spacetime_profinfo_hd(profinfo_shifted));
+}
+
+CAMLprim value caml_spacetime_ocaml_allocation_point_count
+ (value node, value offset)
+{
+ value count = Alloc_point_count(node, Long_val(offset));
+ CAMLassert(!Is_block(count));
+ return count;
+}
+
+CAMLprim value caml_spacetime_ocaml_direct_call_point_callee_node
+ (value node, value offset)
+{
+ return Direct_callee_node(node, Long_val(offset));
+}
+
+CAMLprim value caml_spacetime_ocaml_direct_call_point_call_count
+(value node, value offset)
+{
+ return Direct_call_count(node, Long_val(offset));
+}
+
+CAMLprim value caml_spacetime_ocaml_indirect_call_point_callees
+ (value node, value offset)
+{
+ value callees = Indirect_pc_linked_list(node, Long_val(offset));
+ CAMLassert(Is_block(callees));
+ CAMLassert(Is_c_node(callees));
+ return callees;
+}
+
+CAMLprim value caml_spacetime_c_node_is_call(value node)
+{
+ c_node* c_node;
+ CAMLassert(node != (value) NULL);
+ CAMLassert(Is_c_node(node));
+ c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+ switch (caml_spacetime_offline_classify_c_node(c_node)) {
+ case CALL: return Val_true;
+ case ALLOCATION: return Val_false;
+ }
+ CAMLassert(0);
+ return Val_unit; /* silence compiler warning */
+}
+
+CAMLprim value caml_spacetime_c_node_next(value node)
+{
+ c_node* c_node;
+
+ CAMLassert(node != (value) NULL);
+ CAMLassert(Is_c_node(node));
+ c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+ CAMLassert(c_node->next == Val_unit || Is_c_node(c_node->next));
+ return c_node->next;
+}
+
+CAMLprim value caml_spacetime_c_node_call_site(value node)
+{
+ c_node* c_node;
+ CAMLassert(node != (value) NULL);
+ CAMLassert(Is_c_node(node));
+ c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+ return caml_copy_int64((uint64_t) Decode_c_node_pc(c_node->pc));
+}
+
+CAMLprim value caml_spacetime_c_node_callee_node(value node)
+{
+ c_node* c_node;
+ CAMLassert(node != (value) NULL);
+ CAMLassert(Is_c_node(node));
+ c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+ CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == CALL);
+ /* This might be an uninitialised tail call point: for example if an OCaml
+ callee was indirectly called but the callee wasn't instrumented (e.g. a
+ leaf function that doesn't allocate). */
+ if (Is_tail_caller_node_encoded(c_node->data.call.callee_node)) {
+ return Val_unit;
+ }
+ return c_node->data.call.callee_node;
+}
+
+CAMLprim value caml_spacetime_c_node_call_count(value node)
+{
+ c_node* c_node;
+ CAMLassert(node != (value) NULL);
+ CAMLassert(Is_c_node(node));
+ c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+ CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == CALL);
+ if (Is_tail_caller_node_encoded(c_node->data.call.callee_node)) {
+ return Val_long(0);
+ }
+ return c_node->data.call.call_count;
+}
+
+CAMLprim value caml_spacetime_c_node_profinfo(value node)
+{
+ c_node* c_node;
+ CAMLassert(node != (value) NULL);
+ CAMLassert(Is_c_node(node));
+ c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+ CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION);
+ CAMLassert(!Is_block(c_node->data.allocation.profinfo));
+ return Val_long(Spacetime_profinfo_hd(c_node->data.allocation.profinfo));
+}
+
+CAMLprim value caml_spacetime_c_node_allocation_count(value node)
+{
+ c_node* c_node;
+ CAMLassert(node != (value) NULL);
+ CAMLassert(Is_c_node(node));
+ c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+ CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION);
+ CAMLassert(!Is_block(c_node->data.allocation.count));
+ return c_node->data.allocation.count;
+}
+
+#endif
ROOTDIR=../..
include $(ROOTDIR)/config/Makefile
+include $(ROOTDIR)/Makefile.common
CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
CAMLYACC ?= $(ROOTDIR)/boot/ocamlyacc
clean: partialclean
rm -f dllthreads*$(EXT_DLL) *.$(A) *.$(O)
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-THREADS_LIBDIR=$(INSTALL_LIBDIR)/$(LIBNAME)
-INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
+INSTALL_THREADSLIBDIR=$(INSTALL_LIBDIR)/$(LIBNAME)
install:
if test -f dllthreads$(EXT_DLL); then \
- cp dllthreads$(EXT_DLL) "$(INSTALL_STUBLIBDIR)/dllthreads$(EXT_DLL)"; fi
- cp libthreads.$(A) "$(INSTALL_LIBDIR)"
+ $(INSTALL_PROG) \
+ dllthreads$(EXT_DLL) "$(INSTALL_STUBLIBDIR)/dllthreads$(EXT_DLL)"; \
+ fi
+ $(INSTALL_DATA) libthreads.$(A) "$(INSTALL_LIBDIR)"
cd "$(INSTALL_LIBDIR)"; $(RANLIB) libthreads.$(A)
- mkdir -p "$(THREADS_LIBDIR)"
- cp $(CMIFILES) $(CMIFILES:.cmi=.cmti) threads.cma "$(THREADS_LIBDIR)"
- cp $(MLIFILES) "$(INSTALL_LIBDIR)"
- cp threads.h "$(INSTALL_LIBDIR)/caml"
+ mkdir -p "$(INSTALL_THREADSLIBDIR)"
+ $(INSTALL_DATA) \
+ $(CMIFILES) $(CMIFILES:.cmi=.cmti) threads.cma \
+ "$(INSTALL_THREADSLIBDIR)"
+ $(INSTALL_DATA) $(MLIFILES) "$(INSTALL_LIBDIR)"
+ $(INSTALL_DATA) threads.h "$(INSTALL_LIBDIR)/caml"
installopt:
- cp libthreadsnat.$(A) "$(INSTALL_LIBDIR)"
+ $(INSTALL_DATA) libthreadsnat.$(A) "$(INSTALL_LIBDIR)"
cd "$(INSTALL_LIBDIR)"; $(RANLIB) libthreadsnat.$(A)
- cp $(THREADS_NCOBJS) threads.cmxa threads.$(A) "$(THREADS_LIBDIR)"
- cd "$(THREADS_LIBDIR)" && $(RANLIB) threads.$(A)
+ $(INSTALL_DATA) \
+ $(THREADS_NCOBJS) threads.cmxa threads.$(A) \
+ "$(INSTALL_THREADSLIBDIR)"
+ cd "$(INSTALL_THREADSLIBDIR)" && $(RANLIB) threads.$(A)
.SUFFIXES: .ml .mli .cmo .cmi .cmx
#define _POSIX_PTHREAD_SEMANTICS
#endif
#include <signal.h>
+#include <time.h>
#include <sys/time.h>
#ifdef __linux__
#include <unistd.h>
static void INLINE st_thread_yield(void)
{
-#ifndef __linux__
+#ifdef __linux__
/* sched_yield() doesn't do what we want in Linux 2.6 and up (PR#2663) */
+ /* but not doing anything here would actually disable preemption (PR#7669) */
+ struct timespec t;
+ t.tv_sec = 0;
+ t.tv_nsec = 1;
+ nanosleep(&t, NULL);
+#else
sched_yield();
#endif
}
(* Wait functions *)
-let delay time = ignore(Unix.select [] [] [] time)
+let delay = Unix.sleepf
let wait_read fd = ()
let wait_write fd = ()
(** This function does nothing in this implementation. *)
val wait_timed_read : Unix.file_descr -> float -> bool
-(** See {!Thread.wait_timed_read}.*)
+(** See {!Thread.wait_timed_write}.*)
val wait_timed_write : Unix.file_descr -> float -> bool
(** Suspend the execution of the calling thread until at least
- one character is available for reading ([wait_read]) or
+ one character or EOF is available for reading ([wait_read]) or
one character can be written without blocking ([wait_write])
on the given Unix file descriptor. Wait for at most
the amount of time given as second argument (in seconds).
mutex.cmo : thread.cmi mutex.cmi
mutex.cmx : thread.cmx mutex.cmi
mutex.cmi :
-pervasives.cmo : unix.cmo
-pervasives.cmx : unix.cmx
-thread.cmo : unix.cmo thread.cmi
+stdlib.cmo : unix.cmi marshal.cmo stdlib.cmi
+stdlib.cmx : unix.cmx marshal.cmx stdlib.cmi
+stdlib.cmi : marshal.cmo
+thread.cmo : unix.cmi thread.cmi
thread.cmx : unix.cmx thread.cmi
-thread.cmi : unix.cmo
-threadUnix.cmo : unix.cmo thread.cmi threadUnix.cmi
+thread.cmi : unix.cmi
+threadUnix.cmo : unix.cmi thread.cmi threadUnix.cmi
threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi
-threadUnix.cmi : unix.cmo
-unix.cmo :
-unix.cmx :
+threadUnix.cmi : unix.cmi
+unix.cmo : stdlib.cmi unix.cmi
+unix.cmx : stdlib.cmx unix.cmi
+unix.cmi : stdlib.cmi
# FIXME reduce redundancy by including ../Makefile
include ../../config/Makefile
+include ../../Makefile.common
+
CAMLRUN ?= ../../boot/ocamlrun
CAMLYACC ?= ../../boot/ocamlyacc
LIB=../../stdlib
-LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo pervasives.cmo \
- $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/bytes.cmo \
- $(LIB)/string.cmo $(LIB)/sys.cmo $(LIB)/sort.cmo marshal.cmo \
- $(LIB)/obj.cmo $(LIB)/int32.cmo $(LIB)/int64.cmo \
- $(LIB)/nativeint.cmo $(LIB)/lexing.cmo $(LIB)/parsing.cmo \
- $(LIB)/set.cmo $(LIB)/map.cmo $(LIB)/stack.cmo $(LIB)/queue.cmo \
- $(LIB)/camlinternalLazy.cmo $(LIB)/lazy.cmo $(LIB)/stream.cmo \
- $(LIB)/buffer.cmo $(LIB)/camlinternalFormat.cmo $(LIB)/printf.cmo \
- $(LIB)/arg.cmo $(LIB)/printexc.cmo $(LIB)/gc.cmo $(LIB)/digest.cmo \
- $(LIB)/random.cmo $(LIB)/hashtbl.cmo $(LIB)/format.cmo \
- $(LIB)/scanf.cmo $(LIB)/callback.cmo $(LIB)/camlinternalOO.cmo \
- $(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo $(LIB)/genlex.cmo \
- $(LIB)/weak.cmo $(LIB)/ephemeron.cmo $(LIB)/filename.cmo \
- $(LIB)/complex.cmo $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo \
- $(LIB)/bytesLabels.cmo $(LIB)/stringLabels.cmo \
- $(LIB)/moreLabels.cmo $(LIB)/stdLabels.cmo
+# Object file prefix
+P=stdlib__
+
+LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo stdlib.cmo \
+ $(LIB)/$(P)seq.cmo $(LIB)/$(P)array.cmo $(LIB)/$(P)list.cmo $(LIB)/$(P)char.cmo $(LIB)/$(P)bytes.cmo \
+ $(LIB)/$(P)string.cmo $(LIB)/$(P)sys.cmo $(LIB)/$(P)sort.cmo marshal.cmo \
+ $(LIB)/$(P)obj.cmo $(LIB)/$(P)int32.cmo $(LIB)/$(P)int64.cmo \
+ $(LIB)/$(P)nativeint.cmo $(LIB)/$(P)lexing.cmo $(LIB)/$(P)parsing.cmo \
+ $(LIB)/$(P)set.cmo $(LIB)/$(P)map.cmo $(LIB)/$(P)stack.cmo $(LIB)/$(P)queue.cmo \
+ $(LIB)/camlinternalLazy.cmo $(LIB)/$(P)lazy.cmo $(LIB)/$(P)stream.cmo \
+ $(LIB)/$(P)buffer.cmo $(LIB)/camlinternalFormat.cmo $(LIB)/$(P)printf.cmo \
+ $(LIB)/$(P)arg.cmo $(LIB)/$(P)printexc.cmo $(LIB)/$(P)gc.cmo $(LIB)/$(P)digest.cmo \
+ $(LIB)/$(P)random.cmo $(LIB)/$(P)hashtbl.cmo $(LIB)/$(P)format.cmo \
+ $(LIB)/$(P)scanf.cmo $(LIB)/$(P)callback.cmo $(LIB)/camlinternalOO.cmo \
+ $(LIB)/$(P)oo.cmo $(LIB)/camlinternalMod.cmo $(LIB)/$(P)genlex.cmo \
+ $(LIB)/$(P)weak.cmo $(LIB)/$(P)ephemeron.cmo $(LIB)/$(P)filename.cmo \
+ $(LIB)/$(P)complex.cmo $(LIB)/$(P)arrayLabels.cmo $(LIB)/$(P)listLabels.cmo \
+ $(LIB)/$(P)bytesLabels.cmo $(LIB)/$(P)stringLabels.cmo \
+ $(LIB)/$(P)moreLabels.cmo $(LIB)/$(P)stdLabels.cmo
UNIXLIB=../unix
unix.cma: $(UNIXLIB_OBJS)
$(MKLIB) -ocamlc '$(CAMLC)' -o unix -linkall $(UNIXLIB_OBJS)
-pervasives.cmo: pervasives.mli pervasives.cmi pervasives.ml
- $(CAMLC) ${COMPFLAGS} -nopervasives -c pervasives.ml
+stdlib.cmo: stdlib.mli stdlib.cmi stdlib.ml
+ $(CAMLC) ${COMPFLAGS} -nopervasives \
+ -pp "$(AWK) -f $(LIB)/expand_module_aliases.awk" -o $@ -c stdlib.ml
-pervasives.mli: $(LIB)/pervasives.mli
- ln -s $(LIB)/pervasives.mli pervasives.mli
+stdlib.mli: $(LIB)/stdlib.mli
+ ln -s $(LIB)/stdlib.mli stdlib.mli
-pervasives.cmi: $(LIB)/pervasives.cmi
- ln -s $(LIB)/pervasives.cmi pervasives.cmi
+stdlib.cmi: $(LIB)/stdlib.cmi
+ rm -f stdlib.cmi
+ ln -s $(LIB)/stdlib.cmi stdlib.cmi
-marshal.cmo: marshal.mli marshal.cmi marshal.ml
- $(CAMLC) ${COMPFLAGS} -c marshal.ml
+$(P)marshal.cmo: marshal.mli $(P)marshal.cmi marshal.ml
+ $(CAMLC) ${COMPFLAGS} -o$@ -c marshal.ml
marshal.mli: $(LIB)/marshal.mli
ln -s $(LIB)/marshal.mli marshal.mli
-marshal.cmi: $(LIB)/marshal.cmi
- ln -s $(LIB)/marshal.cmi marshal.cmi
+$(P)marshal.cmi: $(LIB)/$(P)marshal.cmi
+ ln -s $(LIB)/$(P)marshal.cmi $(P)marshal.cmi
unix.mli: $(UNIXLIB)/unix.mli
ln -s -f $(UNIXLIB)/unix.mli unix.mli
clean: partialclean
rm -f libvmthreads.a dllvmthreads.so *.o
- rm -f pervasives.mli marshal.mli unix.mli
-
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
+ rm -f stdlib.mli marshal.mli unix.mli
CMIFILES=thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi
install:
if test -f dllvmthreads.so; then \
- cp dllvmthreads.so "$(INSTALL_STUBLIBDIR)"; \
+ $(INSTALL_PROG) dllvmthreads.so "$(INSTALL_STUBLIBDIR)"; \
fi
mkdir -p "$(INSTALL_LIBDIR)/vmthreads"
- cp libvmthreads.a "$(INSTALL_LIBDIR)/vmthreads"
+ $(INSTALL_DATA) libvmthreads.a "$(INSTALL_LIBDIR)/vmthreads"
cd "$(INSTALL_LIBDIR)/vmthreads"; $(RANLIB) libvmthreads.a
- cp $(CMIFILES) $(CMIFILES:.cmi=.mli) $(CMIFILES:.cmi=.cmti) \
- threads.cma stdlib.cma unix.cma "$(INSTALL_LIBDIR)/vmthreads"
+ $(INSTALL_DATA) \
+ $(CMIFILES) $(CMIFILES:.cmi=.mli) $(CMIFILES:.cmi=.cmti) \
+ threads.cma stdlib.cma unix.cma \
+ "$(INSTALL_LIBDIR)/vmthreads"
installopt:
| Compat_32
external to_bytes: 'a -> extern_flags list -> bytes
- = "caml_output_value_to_string"
+ = "caml_output_value_to_bytes"
external to_string: 'a -> extern_flags list -> string
= "caml_output_value_to_string"
else to_buffer_unsafe buff ofs len v flags
external from_channel: in_channel -> 'a = "caml_input_value"
-external from_bytes_unsafe: bytes -> int -> 'a
- = "caml_input_value_from_string"
+external from_bytes_unsafe: bytes -> int -> 'a = "caml_input_value_from_bytes"
external data_size_unsafe: bytes -> int -> int = "caml_marshal_data_size"
let header_size = 20
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(* Same as ../../stdlib/pervasives.ml, except that I/O functions have
- been redefined to not block the whole process, but only the calling
- thread. *)
-
-(* type 'a option = None | Some of 'a *)
-
-(* Exceptions *)
-
-external register_named_value : string -> 'a -> unit
- = "caml_register_named_value"
-
-let () =
- (* for asmrun/fail.c *)
- register_named_value "Pervasives.array_bound_error"
- (Invalid_argument "index out of bounds")
-
-
-external raise : exn -> 'a = "%raise"
-external raise_notrace : exn -> 'a = "%raise_notrace"
-
-let failwith s = raise(Failure s)
-let invalid_arg s = raise(Invalid_argument s)
-
-exception Exit
-
-(* Composition operators *)
-
-external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
-external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
-
-(* Debugging *)
-
-external __LOC__ : string = "%loc_LOC"
-external __FILE__ : string = "%loc_FILE"
-external __LINE__ : int = "%loc_LINE"
-external __MODULE__ : string = "%loc_MODULE"
-external __POS__ : string * int * int * int = "%loc_POS"
-
-external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
-external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
-external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
-
-(* Comparisons *)
-
-external ( = ) : 'a -> 'a -> bool = "%equal"
-external ( <> ) : 'a -> 'a -> bool = "%notequal"
-external ( < ) : 'a -> 'a -> bool = "%lessthan"
-external ( > ) : 'a -> 'a -> bool = "%greaterthan"
-external ( <= ) : 'a -> 'a -> bool = "%lessequal"
-external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
-external compare : 'a -> 'a -> int = "%compare"
-
-let min x y = if x <= y then x else y
-let max x y = if x >= y then x else y
-
-external ( == ) : 'a -> 'a -> bool = "%eq"
-external ( != ) : 'a -> 'a -> bool = "%noteq"
-
-(* Boolean operations *)
-
-external not : bool -> bool = "%boolnot"
-external ( & ) : bool -> bool -> bool = "%sequand"
-external ( && ) : bool -> bool -> bool = "%sequand"
-external ( or ) : bool -> bool -> bool = "%sequor"
-external ( || ) : bool -> bool -> bool = "%sequor"
-
-(* Integer operations *)
-
-external ( ~- ) : int -> int = "%negint"
-external ( ~+ ) : int -> int = "%identity"
-external succ : int -> int = "%succint"
-external pred : int -> int = "%predint"
-external ( + ) : int -> int -> int = "%addint"
-external ( - ) : int -> int -> int = "%subint"
-external ( * ) : int -> int -> int = "%mulint"
-external ( / ) : int -> int -> int = "%divint"
-external ( mod ) : int -> int -> int = "%modint"
-
-let abs x = if x >= 0 then x else -x
-
-external ( land ) : int -> int -> int = "%andint"
-external ( lor ) : int -> int -> int = "%orint"
-external ( lxor ) : int -> int -> int = "%xorint"
-
-let lnot x = x lxor (-1)
-
-external ( lsl ) : int -> int -> int = "%lslint"
-external ( lsr ) : int -> int -> int = "%lsrint"
-external ( asr ) : int -> int -> int = "%asrint"
-
-let max_int = (-1) lsr 1
-let min_int = max_int + 1
-
-(* Floating-point operations *)
-
-external ( ~-. ) : float -> float = "%negfloat"
-external ( ~+. ) : float -> float = "%identity"
-external ( +. ) : float -> float -> float = "%addfloat"
-external ( -. ) : float -> float -> float = "%subfloat"
-external ( *. ) : float -> float -> float = "%mulfloat"
-external ( /. ) : float -> float -> float = "%divfloat"
-external ( ** ) : float -> float -> float = "caml_power_float" "pow"
- [@@unboxed] [@@noalloc]
-external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc]
-external expm1 : float -> float = "caml_expm1_float" "caml_expm1"
- [@@unboxed] [@@noalloc]
-external acos : float -> float = "caml_acos_float" "acos"
- [@@unboxed] [@@noalloc]
-external asin : float -> float = "caml_asin_float" "asin"
- [@@unboxed] [@@noalloc]
-external atan : float -> float = "caml_atan_float" "atan"
- [@@unboxed] [@@noalloc]
-external atan2 : float -> float -> float = "caml_atan2_float" "atan2"
- [@@unboxed] [@@noalloc]
-external hypot : float -> float -> float
- = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc]
-external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc]
-external cosh : float -> float = "caml_cosh_float" "cosh"
- [@@unboxed] [@@noalloc]
-external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc]
-external log10 : float -> float = "caml_log10_float" "log10"
- [@@unboxed] [@@noalloc]
-external log1p : float -> float = "caml_log1p_float" "caml_log1p"
- [@@unboxed] [@@noalloc]
-external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc]
-external sinh : float -> float = "caml_sinh_float" "sinh"
- [@@unboxed] [@@noalloc]
-external sqrt : float -> float = "caml_sqrt_float" "sqrt"
- [@@unboxed] [@@noalloc]
-external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc]
-external tanh : float -> float = "caml_tanh_float" "tanh"
- [@@unboxed] [@@noalloc]
-external ceil : float -> float = "caml_ceil_float" "ceil"
- [@@unboxed] [@@noalloc]
-external floor : float -> float = "caml_floor_float" "floor"
- [@@unboxed] [@@noalloc]
-external abs_float : float -> float = "%absfloat"
-external copysign : float -> float -> float
- = "caml_copysign_float" "caml_copysign"
- [@@unboxed] [@@noalloc]
-external mod_float : float -> float -> float = "caml_fmod_float" "fmod"
- [@@unboxed] [@@noalloc]
-external frexp : float -> float * int = "caml_frexp_float"
-external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
- "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc]
-external modf : float -> float * float = "caml_modf_float"
-external float : int -> float = "%floatofint"
-external float_of_int : int -> float = "%floatofint"
-external truncate : float -> int = "%intoffloat"
-external int_of_float : float -> int = "%intoffloat"
-external float_of_bits : int64 -> float
- = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed"
- [@@unboxed] [@@noalloc]
-let infinity =
- float_of_bits 0x7F_F0_00_00_00_00_00_00L
-let neg_infinity =
- float_of_bits 0xFF_F0_00_00_00_00_00_00L
-let nan =
- float_of_bits 0x7F_F0_00_00_00_00_00_01L
-let max_float =
- float_of_bits 0x7F_EF_FF_FF_FF_FF_FF_FFL
-let min_float =
- float_of_bits 0x00_10_00_00_00_00_00_00L
-let epsilon_float =
- float_of_bits 0x3C_B0_00_00_00_00_00_00L
-
-type fpclass =
- FP_normal
- | FP_subnormal
- | FP_zero
- | FP_infinite
- | FP_nan
-external classify_float : (float [@unboxed]) -> fpclass =
- "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
-
-(* String and byte sequence operations -- more in modules String and Bytes *)
-
-external string_length : string -> int = "%string_length"
-external bytes_length : bytes -> int = "%bytes_length"
-external bytes_create : int -> bytes = "caml_create_bytes"
-external string_blit : string -> int -> bytes -> int -> int -> unit
- = "caml_blit_string" [@@noalloc]
-external bytes_blit : bytes -> int -> bytes -> int -> int -> unit
- = "caml_blit_bytes" [@@noalloc]
-external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
-external bytes_unsafe_of_string : string -> bytes = "%bytes_of_string"
-
-let ( ^ ) s1 s2 =
- let l1 = string_length s1 and l2 = string_length s2 in
- let s = bytes_create (l1 + l2) in
- string_blit s1 0 s 0 l1;
- string_blit s2 0 s l1 l2;
- bytes_unsafe_to_string s
-
-(* Character operations -- more in module Char *)
-
-external int_of_char : char -> int = "%identity"
-external unsafe_char_of_int : int -> char = "%identity"
-let char_of_int n =
- if n < 0 || n > 255 then invalid_arg "char_of_int" else unsafe_char_of_int n
-
-(* Unit operations *)
-
-external ignore : 'a -> unit = "%ignore"
-
-(* Pair operations *)
-
-external fst : 'a * 'b -> 'a = "%field0"
-external snd : 'a * 'b -> 'b = "%field1"
-
-(* References *)
-
-type 'a ref = { mutable contents : 'a }
-external ref : 'a -> 'a ref = "%makemutable"
-external ( ! ) : 'a ref -> 'a = "%field0"
-external ( := ) : 'a ref -> 'a -> unit = "%setfield0"
-external incr : int ref -> unit = "%incr"
-external decr : int ref -> unit = "%decr"
-
-(* Result type *)
-
-type ('a,'b) result = Ok of 'a | Error of 'b
-
-(* String conversion functions *)
-
-external format_int : string -> int -> string = "caml_format_int"
-external format_float : string -> float -> string = "caml_format_float"
-
-let string_of_bool b =
- if b then "true" else "false"
-let bool_of_string = function
- | "true" -> true
- | "false" -> false
- | _ -> invalid_arg "bool_of_string"
-
-let bool_of_string_opt = function
- | "true" -> Some true
- | "false" -> Some false
- | _ -> None
-
-let string_of_int n =
- format_int "%d" n
-
-external int_of_string : string -> int = "caml_int_of_string"
-
-let int_of_string_opt s =
- (* TODO: provide this directly as a non-raising primitive. *)
- try Some (int_of_string s)
- with Failure _ -> None
-
-external string_get : string -> int -> char = "%string_safe_get"
-
-let valid_float_lexem s =
- let l = string_length s in
- let rec loop i =
- if i >= l then s ^ "." else
- match string_get s i with
- | '0' .. '9' | '-' -> loop (i + 1)
- | _ -> s
- in
- loop 0
-
-let string_of_float f = valid_float_lexem (format_float "%.12g" f)
-
-external float_of_string : string -> float = "caml_float_of_string"
-
-let float_of_string_opt s =
- (* TODO: provide this directly as a non-raising primitive. *)
- try Some (float_of_string s)
- with Failure _ -> None
-
-(* List operations -- more in module List *)
-
-let rec ( @ ) l1 l2 =
- match l1 with
- [] -> l2
- | hd :: tl -> hd :: (tl @ l2)
-
-(* I/O operations *)
-
-type in_channel
-type out_channel
-
-external open_descriptor_out : int -> out_channel
- = "caml_ml_open_descriptor_out"
-external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in"
-
-let stdin = open_descriptor_in 0
-let stdout = open_descriptor_out 1
-let stderr = open_descriptor_out 2
-
-(* Non-blocking stuff *)
-
-external thread_wait_read_prim : Unix.file_descr -> unit = "thread_wait_read"
-external thread_wait_write_prim : Unix.file_descr -> unit = "thread_wait_write"
-
-let thread_wait_read fd = thread_wait_read_prim fd
-let thread_wait_write fd = thread_wait_write_prim fd
-
-external descr_inchan : in_channel -> Unix.file_descr
- = "caml_channel_descriptor"
-external descr_outchan : out_channel -> Unix.file_descr
- = "caml_channel_descriptor"
-
-let wait_inchan ic = thread_wait_read (descr_inchan ic)
-
-let wait_outchan oc len = thread_wait_write (descr_outchan oc)
-
-(* General output functions *)
-
-type open_flag =
- Open_rdonly | Open_wronly | Open_append
- | Open_creat | Open_trunc | Open_excl
- | Open_binary | Open_text | Open_nonblock
-
-external open_desc : string -> open_flag list -> int -> int = "caml_sys_open"
-
-external set_out_channel_name: out_channel -> string -> unit =
- "caml_ml_set_channel_name"
-
-let open_out_gen mode perm name =
- let c = open_descriptor_out(open_desc name mode perm) in
- set_out_channel_name c name;
- c
-
-let open_out name =
- open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name
-
-let open_out_bin name =
- open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name
-
-external flush_partial : out_channel -> bool = "caml_ml_flush_partial"
-
-let rec flush oc =
- let success =
- try
- flush_partial oc
- with Sys_blocked_io ->
- wait_outchan oc (-1); false in
- if success then () else flush oc
-
-external out_channels_list : unit -> out_channel list
- = "caml_ml_out_channels_list"
-
-let flush_all () =
- let rec iter = function
- [] -> ()
- | a::l ->
- begin try
- flush a
- with Sys_error _ ->
- () (* ignore channels closed during a preceding flush. *)
- end;
- iter l
- in iter (out_channels_list ())
-
-external unsafe_output_partial : out_channel -> bytes -> int -> int -> int
- = "caml_ml_output_partial"
-
-let rec unsafe_output oc buf pos len =
- if len > 0 then begin
- let written =
- try
- unsafe_output_partial oc buf pos len
- with Sys_blocked_io ->
- wait_outchan oc len; 0 in
- unsafe_output oc buf (pos + written) (len - written)
- end
-
-external output_char_blocking : out_channel -> char -> unit
- = "caml_ml_output_char"
-external output_byte_blocking : out_channel -> int -> unit
- = "caml_ml_output_char"
-
-let rec output_char oc c =
- try
- output_char_blocking oc c
- with Sys_blocked_io ->
- wait_outchan oc 1; output_char oc c
-
-let output_bytes oc s =
- unsafe_output oc s 0 (bytes_length s)
-
-let output_string oc s =
- unsafe_output oc (bytes_unsafe_of_string s) 0 (string_length s)
-
-let output oc s ofs len =
- if ofs < 0 || len < 0 || ofs > bytes_length s - len
- then invalid_arg "output"
- else unsafe_output oc s ofs len
-
-let output_substring oc s ofs len =
- output oc (bytes_unsafe_of_string s) ofs len
-
-let rec output_byte oc b =
- try
- output_byte_blocking oc b
- with Sys_blocked_io ->
- wait_outchan oc 1; output_byte oc b
-
-let output_binary_int oc n =
- output_byte oc (n asr 24);
- output_byte oc (n asr 16);
- output_byte oc (n asr 8);
- output_byte oc n
-
-external marshal_to_string : 'a -> unit list -> string
- = "caml_output_value_to_string"
-
-let output_value oc v = output_string oc (marshal_to_string v [])
-
-external seek_out_blocking : out_channel -> int -> unit = "caml_ml_seek_out"
-
-let seek_out oc pos = flush oc; seek_out_blocking oc pos
-
-external pos_out : out_channel -> int = "caml_ml_pos_out"
-external out_channel_length : out_channel -> int = "caml_ml_channel_size"
-external close_out_channel : out_channel -> unit = "caml_ml_close_channel"
-let close_out oc = flush oc; close_out_channel oc
-let close_out_noerr oc =
- (try flush oc with _ -> ());
- (try close_out_channel oc with _ -> ())
-external set_binary_mode_out : out_channel -> bool -> unit
- = "caml_ml_set_binary_mode"
-
-(* General input functions *)
-
-external set_in_channel_name: in_channel -> string -> unit =
- "caml_ml_set_channel_name"
-
-let open_in_gen mode perm name =
- let c = open_descriptor_in(open_desc name mode perm) in
- set_in_channel_name c name;
- c
-
-let open_in name =
- open_in_gen [Open_rdonly; Open_text] 0 name
-
-let open_in_bin name =
- open_in_gen [Open_rdonly; Open_binary] 0 name
-
-external input_char_blocking : in_channel -> char = "caml_ml_input_char"
-external input_byte_blocking : in_channel -> int = "caml_ml_input_char"
-
-let rec input_char ic =
- try
- input_char_blocking ic
- with Sys_blocked_io ->
- wait_inchan ic; input_char ic
-
-external unsafe_input_blocking : in_channel -> bytes -> int -> int -> int
- = "caml_ml_input"
-
-let rec unsafe_input ic s ofs len =
- try
- unsafe_input_blocking ic s ofs len
- with Sys_blocked_io ->
- wait_inchan ic; unsafe_input ic s ofs len
-
-let input ic s ofs len =
- if ofs < 0 || len < 0 || ofs > bytes_length s - len
- then invalid_arg "input"
- else unsafe_input ic s ofs len
-
-let rec unsafe_really_input ic s ofs len =
- if len <= 0 then () else begin
- let r = unsafe_input ic s ofs len in
- if r = 0
- then raise End_of_file
- else unsafe_really_input ic s (ofs + r) (len - r)
- end
-
-let really_input ic s ofs len =
- if ofs < 0 || len < 0 || ofs > bytes_length s - len
- then invalid_arg "really_input"
- else unsafe_really_input ic s ofs len
-
-let really_input_string ic len =
- let s = bytes_create len in
- really_input ic s 0 len;
- bytes_unsafe_to_string s
-
-external bytes_set : bytes -> int -> char -> unit = "%bytes_safe_set"
-
-let input_line ic =
- let buf = ref (bytes_create 128) in
- let pos = ref 0 in
- begin try
- while true do
- if !pos = bytes_length !buf then begin
- let newbuf = bytes_create (2 * !pos) in
- bytes_blit !buf 0 newbuf 0 !pos;
- buf := newbuf
- end;
- let c = input_char ic in
- if c = '\n' then raise Exit;
- bytes_set !buf !pos c;
- incr pos
- done
- with Exit -> ()
- | End_of_file -> if !pos = 0 then raise End_of_file
- end;
- let res = bytes_create !pos in
- bytes_blit !buf 0 res 0 !pos;
- bytes_unsafe_to_string res
-
-let rec input_byte ic =
- try
- input_byte_blocking ic
- with Sys_blocked_io ->
- wait_inchan ic; input_byte ic
-
-let input_binary_int ic =
- let b1 = input_byte ic in
- let n1 = if b1 >= 128 then b1 - 256 else b1 in
- let b2 = input_byte ic in
- let b3 = input_byte ic in
- let b4 = input_byte ic in
- (n1 lsl 24) + (b2 lsl 16) + (b3 lsl 8) + b4
-
-external unmarshal : bytes -> int -> 'a = "caml_input_value_from_string"
-external marshal_data_size : bytes -> int -> int = "caml_marshal_data_size"
-
-let input_value ic =
- let header = bytes_create 20 in
- really_input ic header 0 20;
- let bsize = marshal_data_size header 0 in
- let buffer = bytes_create (20 + bsize) in
- bytes_blit header 0 buffer 0 20;
- really_input ic buffer 20 bsize;
- unmarshal buffer 0
-
-external seek_in : in_channel -> int -> unit = "caml_ml_seek_in"
-external pos_in : in_channel -> int = "caml_ml_pos_in"
-external in_channel_length : in_channel -> int = "caml_ml_channel_size"
-external close_in : in_channel -> unit = "caml_ml_close_channel"
-let close_in_noerr ic = (try close_in ic with _ -> ())
-external set_binary_mode_in : in_channel -> bool -> unit
- = "caml_ml_set_binary_mode"
-
-(* Output functions on standard output *)
-
-let print_char c = output_char stdout c
-let print_string s = output_string stdout s
-let print_bytes s = output_bytes stdout s
-let print_int i = output_string stdout (string_of_int i)
-let print_float f = output_string stdout (string_of_float f)
-let print_endline s =
- output_string stdout s; output_char stdout '\n'; flush stdout
-let print_newline () = output_char stdout '\n'; flush stdout
-
-(* Output functions on standard error *)
-
-let prerr_char c = output_char stderr c
-let prerr_string s = output_string stderr s
-let prerr_bytes s = output_bytes stderr s
-let prerr_int i = output_string stderr (string_of_int i)
-let prerr_float f = output_string stderr (string_of_float f)
-let prerr_endline s =
- output_string stderr s; output_char stderr '\n'; flush stderr
-let prerr_newline () = output_char stderr '\n'; flush stderr
-
-(* Input functions on standard input *)
-
-let read_line () = flush stdout; input_line stdin
-let read_int () = int_of_string(read_line())
-let read_int_opt () = int_of_string_opt(read_line())
-let read_float () = float_of_string(read_line())
-let read_float_opt () = float_of_string_opt(read_line())
-
-(* Operations on large files *)
-
-module LargeFile =
- struct
- external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64"
- external pos_out : out_channel -> int64 = "caml_ml_pos_out_64"
- external out_channel_length : out_channel -> int64
- = "caml_ml_channel_size_64"
- external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64"
- external pos_in : in_channel -> int64 = "caml_ml_pos_in_64"
- external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64"
- end
-
-(* Formats *)
-
-type ('a, 'b, 'c, 'd, 'e, 'f) format6
- = ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
- = Format of ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt
- * string
-
-type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
-
-type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
-
-let string_of_format (Format (_fmt, str)) = str
-
-external format_of_string :
- ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
- ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
-
-let ( ^^ ) (Format (fmt1, str1)) (Format (fmt2, str2)) =
- Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2,
- str1 ^ "%," ^ str2)
-
-(* Miscellaneous *)
-
-external sys_exit : int -> 'a = "caml_sys_exit"
-
-let exit_function = ref flush_all
-
-let at_exit f =
- let g = !exit_function in
- exit_function := (fun () -> f(); g())
-
-let do_at_exit () = (!exit_function) ()
-
-let exit retcode =
- do_at_exit ();
- sys_exit retcode
-
-let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Same as ../../stdlib/stdlib.ml, except that I/O functions have
+ been redefined to not block the whole process, but only the calling
+ thread. *)
+
+module Pervasives = struct
+(* type 'a option = None | Some of 'a *)
+
+(* Exceptions *)
+
+external register_named_value : string -> 'a -> unit
+ = "caml_register_named_value"
+
+let () =
+ (* for asmrun/fail.c *)
+ register_named_value "Pervasives.array_bound_error"
+ (Invalid_argument "index out of bounds")
+
+
+external raise : exn -> 'a = "%raise"
+external raise_notrace : exn -> 'a = "%raise_notrace"
+
+let failwith s = raise(Failure s)
+let invalid_arg s = raise(Invalid_argument s)
+
+exception Exit
+
+(* Composition operators *)
+
+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
+
+(* Debugging *)
+
+external __LOC__ : string = "%loc_LOC"
+external __FILE__ : string = "%loc_FILE"
+external __LINE__ : int = "%loc_LINE"
+external __MODULE__ : string = "%loc_MODULE"
+external __POS__ : string * int * int * int = "%loc_POS"
+
+external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
+external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
+external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
+
+(* Comparisons *)
+
+external ( = ) : 'a -> 'a -> bool = "%equal"
+external ( <> ) : 'a -> 'a -> bool = "%notequal"
+external ( < ) : 'a -> 'a -> bool = "%lessthan"
+external ( > ) : 'a -> 'a -> bool = "%greaterthan"
+external ( <= ) : 'a -> 'a -> bool = "%lessequal"
+external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
+external compare : 'a -> 'a -> int = "%compare"
+
+let min x y = if x <= y then x else y
+let max x y = if x >= y then x else y
+
+external ( == ) : 'a -> 'a -> bool = "%eq"
+external ( != ) : 'a -> 'a -> bool = "%noteq"
+
+(* Boolean operations *)
+
+external not : bool -> bool = "%boolnot"
+external ( & ) : bool -> bool -> bool = "%sequand"
+external ( && ) : bool -> bool -> bool = "%sequand"
+external ( or ) : bool -> bool -> bool = "%sequor"
+external ( || ) : bool -> bool -> bool = "%sequor"
+
+(* Integer operations *)
+
+external ( ~- ) : int -> int = "%negint"
+external ( ~+ ) : int -> int = "%identity"
+external succ : int -> int = "%succint"
+external pred : int -> int = "%predint"
+external ( + ) : int -> int -> int = "%addint"
+external ( - ) : int -> int -> int = "%subint"
+external ( * ) : int -> int -> int = "%mulint"
+external ( / ) : int -> int -> int = "%divint"
+external ( mod ) : int -> int -> int = "%modint"
+
+let abs x = if x >= 0 then x else -x
+
+external ( land ) : int -> int -> int = "%andint"
+external ( lor ) : int -> int -> int = "%orint"
+external ( lxor ) : int -> int -> int = "%xorint"
+
+let lnot x = x lxor (-1)
+
+external ( lsl ) : int -> int -> int = "%lslint"
+external ( lsr ) : int -> int -> int = "%lsrint"
+external ( asr ) : int -> int -> int = "%asrint"
+
+let max_int = (-1) lsr 1
+let min_int = max_int + 1
+
+(* Floating-point operations *)
+
+external ( ~-. ) : float -> float = "%negfloat"
+external ( ~+. ) : float -> float = "%identity"
+external ( +. ) : float -> float -> float = "%addfloat"
+external ( -. ) : float -> float -> float = "%subfloat"
+external ( *. ) : float -> float -> float = "%mulfloat"
+external ( /. ) : float -> float -> float = "%divfloat"
+external ( ** ) : float -> float -> float = "caml_power_float" "pow"
+ [@@unboxed] [@@noalloc]
+external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc]
+external expm1 : float -> float = "caml_expm1_float" "caml_expm1"
+ [@@unboxed] [@@noalloc]
+external acos : float -> float = "caml_acos_float" "acos"
+ [@@unboxed] [@@noalloc]
+external asin : float -> float = "caml_asin_float" "asin"
+ [@@unboxed] [@@noalloc]
+external atan : float -> float = "caml_atan_float" "atan"
+ [@@unboxed] [@@noalloc]
+external atan2 : float -> float -> float = "caml_atan2_float" "atan2"
+ [@@unboxed] [@@noalloc]
+external hypot : float -> float -> float
+ = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc]
+external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc]
+external cosh : float -> float = "caml_cosh_float" "cosh"
+ [@@unboxed] [@@noalloc]
+external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc]
+external log10 : float -> float = "caml_log10_float" "log10"
+ [@@unboxed] [@@noalloc]
+external log1p : float -> float = "caml_log1p_float" "caml_log1p"
+ [@@unboxed] [@@noalloc]
+external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc]
+external sinh : float -> float = "caml_sinh_float" "sinh"
+ [@@unboxed] [@@noalloc]
+external sqrt : float -> float = "caml_sqrt_float" "sqrt"
+ [@@unboxed] [@@noalloc]
+external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc]
+external tanh : float -> float = "caml_tanh_float" "tanh"
+ [@@unboxed] [@@noalloc]
+external ceil : float -> float = "caml_ceil_float" "ceil"
+ [@@unboxed] [@@noalloc]
+external floor : float -> float = "caml_floor_float" "floor"
+ [@@unboxed] [@@noalloc]
+external abs_float : float -> float = "%absfloat"
+external copysign : float -> float -> float
+ = "caml_copysign_float" "caml_copysign"
+ [@@unboxed] [@@noalloc]
+external mod_float : float -> float -> float = "caml_fmod_float" "fmod"
+ [@@unboxed] [@@noalloc]
+external frexp : float -> float * int = "caml_frexp_float"
+external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
+ "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc]
+external modf : float -> float * float = "caml_modf_float"
+external float : int -> float = "%floatofint"
+external float_of_int : int -> float = "%floatofint"
+external truncate : float -> int = "%intoffloat"
+external int_of_float : float -> int = "%intoffloat"
+external float_of_bits : int64 -> float
+ = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed"
+ [@@unboxed] [@@noalloc]
+let infinity =
+ float_of_bits 0x7F_F0_00_00_00_00_00_00L
+let neg_infinity =
+ float_of_bits 0xFF_F0_00_00_00_00_00_00L
+let nan =
+ float_of_bits 0x7F_F0_00_00_00_00_00_01L
+let max_float =
+ float_of_bits 0x7F_EF_FF_FF_FF_FF_FF_FFL
+let min_float =
+ float_of_bits 0x00_10_00_00_00_00_00_00L
+let epsilon_float =
+ float_of_bits 0x3C_B0_00_00_00_00_00_00L
+
+type fpclass =
+ FP_normal
+ | FP_subnormal
+ | FP_zero
+ | FP_infinite
+ | FP_nan
+external classify_float : (float [@unboxed]) -> fpclass =
+ "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
+
+(* String and byte sequence operations -- more in modules String and Bytes *)
+
+external string_length : string -> int = "%string_length"
+external bytes_length : bytes -> int = "%bytes_length"
+external bytes_create : int -> bytes = "caml_create_bytes"
+external string_blit : string -> int -> bytes -> int -> int -> unit
+ = "caml_blit_string" [@@noalloc]
+external bytes_blit : bytes -> int -> bytes -> int -> int -> unit
+ = "caml_blit_bytes" [@@noalloc]
+external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
+external bytes_unsafe_of_string : string -> bytes = "%bytes_of_string"
+
+let ( ^ ) s1 s2 =
+ let l1 = string_length s1 and l2 = string_length s2 in
+ let s = bytes_create (l1 + l2) in
+ string_blit s1 0 s 0 l1;
+ string_blit s2 0 s l1 l2;
+ bytes_unsafe_to_string s
+
+(* Character operations -- more in module Char *)
+
+external int_of_char : char -> int = "%identity"
+external unsafe_char_of_int : int -> char = "%identity"
+let char_of_int n =
+ if n < 0 || n > 255 then invalid_arg "char_of_int" else unsafe_char_of_int n
+
+(* Unit operations *)
+
+external ignore : 'a -> unit = "%ignore"
+
+(* Pair operations *)
+
+external fst : 'a * 'b -> 'a = "%field0"
+external snd : 'a * 'b -> 'b = "%field1"
+
+(* References *)
+
+type 'a ref = { mutable contents : 'a }
+external ref : 'a -> 'a ref = "%makemutable"
+external ( ! ) : 'a ref -> 'a = "%field0"
+external ( := ) : 'a ref -> 'a -> unit = "%setfield0"
+external incr : int ref -> unit = "%incr"
+external decr : int ref -> unit = "%decr"
+
+(* Result type *)
+
+type ('a,'b) result = Ok of 'a | Error of 'b
+
+(* String conversion functions *)
+
+external format_int : string -> int -> string = "caml_format_int"
+external format_float : string -> float -> string = "caml_format_float"
+
+let string_of_bool b =
+ if b then "true" else "false"
+let bool_of_string = function
+ | "true" -> true
+ | "false" -> false
+ | _ -> invalid_arg "bool_of_string"
+
+let bool_of_string_opt = function
+ | "true" -> Some true
+ | "false" -> Some false
+ | _ -> None
+
+let string_of_int n =
+ format_int "%d" n
+
+external int_of_string : string -> int = "caml_int_of_string"
+
+let int_of_string_opt s =
+ (* TODO: provide this directly as a non-raising primitive. *)
+ try Some (int_of_string s)
+ with Failure _ -> None
+
+external string_get : string -> int -> char = "%string_safe_get"
+
+let valid_float_lexem s =
+ let l = string_length s in
+ let rec loop i =
+ if i >= l then s ^ "." else
+ match string_get s i with
+ | '0' .. '9' | '-' -> loop (i + 1)
+ | _ -> s
+ in
+ loop 0
+
+let string_of_float f = valid_float_lexem (format_float "%.12g" f)
+
+external float_of_string : string -> float = "caml_float_of_string"
+
+let float_of_string_opt s =
+ (* TODO: provide this directly as a non-raising primitive. *)
+ try Some (float_of_string s)
+ with Failure _ -> None
+
+(* List operations -- more in module List *)
+
+let rec ( @ ) l1 l2 =
+ match l1 with
+ [] -> l2
+ | hd :: tl -> hd :: (tl @ l2)
+
+(* I/O operations *)
+
+type in_channel
+type out_channel
+
+external open_descriptor_out : int -> out_channel
+ = "caml_ml_open_descriptor_out"
+external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in"
+
+let stdin = open_descriptor_in 0
+let stdout = open_descriptor_out 1
+let stderr = open_descriptor_out 2
+
+(* Non-blocking stuff *)
+
+external thread_wait_read_prim : Unix.file_descr -> unit = "thread_wait_read"
+external thread_wait_write_prim : Unix.file_descr -> unit = "thread_wait_write"
+
+let thread_wait_read fd = thread_wait_read_prim fd
+let thread_wait_write fd = thread_wait_write_prim fd
+
+external descr_inchan : in_channel -> Unix.file_descr
+ = "caml_channel_descriptor"
+external descr_outchan : out_channel -> Unix.file_descr
+ = "caml_channel_descriptor"
+
+let wait_inchan ic = thread_wait_read (descr_inchan ic)
+
+let wait_outchan oc len = thread_wait_write (descr_outchan oc)
+
+(* General output functions *)
+
+type open_flag =
+ Open_rdonly | Open_wronly | Open_append
+ | Open_creat | Open_trunc | Open_excl
+ | Open_binary | Open_text | Open_nonblock
+
+external open_desc : string -> open_flag list -> int -> int = "caml_sys_open"
+
+external set_out_channel_name: out_channel -> string -> unit =
+ "caml_ml_set_channel_name"
+
+let open_out_gen mode perm name =
+ let c = open_descriptor_out(open_desc name mode perm) in
+ set_out_channel_name c name;
+ c
+
+let open_out name =
+ open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name
+
+let open_out_bin name =
+ open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name
+
+external flush_partial : out_channel -> bool = "caml_ml_flush_partial"
+
+let rec flush oc =
+ let success =
+ try
+ flush_partial oc
+ with Sys_blocked_io ->
+ wait_outchan oc (-1); false in
+ if success then () else flush oc
+
+external out_channels_list : unit -> out_channel list
+ = "caml_ml_out_channels_list"
+
+let flush_all () =
+ let rec iter = function
+ [] -> ()
+ | a::l ->
+ begin try
+ flush a
+ with Sys_error _ ->
+ () (* ignore channels closed during a preceding flush. *)
+ end;
+ iter l
+ in iter (out_channels_list ())
+
+external unsafe_output_partial : out_channel -> bytes -> int -> int -> int
+ = "caml_ml_output_partial"
+
+let rec unsafe_output oc buf pos len =
+ if len > 0 then begin
+ let written =
+ try
+ unsafe_output_partial oc buf pos len
+ with Sys_blocked_io ->
+ wait_outchan oc len; 0 in
+ unsafe_output oc buf (pos + written) (len - written)
+ end
+
+external output_char_blocking : out_channel -> char -> unit
+ = "caml_ml_output_char"
+external output_byte_blocking : out_channel -> int -> unit
+ = "caml_ml_output_char"
+
+let rec output_char oc c =
+ try
+ output_char_blocking oc c
+ with Sys_blocked_io ->
+ wait_outchan oc 1; output_char oc c
+
+let output_bytes oc s =
+ unsafe_output oc s 0 (bytes_length s)
+
+let output_string oc s =
+ unsafe_output oc (bytes_unsafe_of_string s) 0 (string_length s)
+
+let output oc s ofs len =
+ if ofs < 0 || len < 0 || ofs > bytes_length s - len
+ then invalid_arg "output"
+ else unsafe_output oc s ofs len
+
+let output_substring oc s ofs len =
+ output oc (bytes_unsafe_of_string s) ofs len
+
+let rec output_byte oc b =
+ try
+ output_byte_blocking oc b
+ with Sys_blocked_io ->
+ wait_outchan oc 1; output_byte oc b
+
+let output_binary_int oc n =
+ output_byte oc (n asr 24);
+ output_byte oc (n asr 16);
+ output_byte oc (n asr 8);
+ output_byte oc n
+
+external marshal_to_string : 'a -> unit list -> string
+ = "caml_output_value_to_string"
+
+let output_value oc v = output_string oc (marshal_to_string v [])
+
+external seek_out_blocking : out_channel -> int -> unit = "caml_ml_seek_out"
+
+let seek_out oc pos = flush oc; seek_out_blocking oc pos
+
+external pos_out : out_channel -> int = "caml_ml_pos_out"
+external out_channel_length : out_channel -> int = "caml_ml_channel_size"
+external close_out_channel : out_channel -> unit = "caml_ml_close_channel"
+let close_out oc = flush oc; close_out_channel oc
+let close_out_noerr oc =
+ (try flush oc with _ -> ());
+ (try close_out_channel oc with _ -> ())
+external set_binary_mode_out : out_channel -> bool -> unit
+ = "caml_ml_set_binary_mode"
+
+(* General input functions *)
+
+external set_in_channel_name: in_channel -> string -> unit =
+ "caml_ml_set_channel_name"
+
+let open_in_gen mode perm name =
+ let c = open_descriptor_in(open_desc name mode perm) in
+ set_in_channel_name c name;
+ c
+
+let open_in name =
+ open_in_gen [Open_rdonly; Open_text] 0 name
+
+let open_in_bin name =
+ open_in_gen [Open_rdonly; Open_binary] 0 name
+
+external input_char_blocking : in_channel -> char = "caml_ml_input_char"
+external input_byte_blocking : in_channel -> int = "caml_ml_input_char"
+
+let rec input_char ic =
+ try
+ input_char_blocking ic
+ with Sys_blocked_io ->
+ wait_inchan ic; input_char ic
+
+external unsafe_input_blocking : in_channel -> bytes -> int -> int -> int
+ = "caml_ml_input"
+
+let rec unsafe_input ic s ofs len =
+ try
+ unsafe_input_blocking ic s ofs len
+ with Sys_blocked_io ->
+ wait_inchan ic; unsafe_input ic s ofs len
+
+let input ic s ofs len =
+ if ofs < 0 || len < 0 || ofs > bytes_length s - len
+ then invalid_arg "input"
+ else unsafe_input ic s ofs len
+
+let rec unsafe_really_input ic s ofs len =
+ if len <= 0 then () else begin
+ let r = unsafe_input ic s ofs len in
+ if r = 0
+ then raise End_of_file
+ else unsafe_really_input ic s (ofs + r) (len - r)
+ end
+
+let really_input ic s ofs len =
+ if ofs < 0 || len < 0 || ofs > bytes_length s - len
+ then invalid_arg "really_input"
+ else unsafe_really_input ic s ofs len
+
+let really_input_string ic len =
+ let s = bytes_create len in
+ really_input ic s 0 len;
+ bytes_unsafe_to_string s
+
+external bytes_set : bytes -> int -> char -> unit = "%bytes_safe_set"
+
+let input_line ic =
+ let buf = ref (bytes_create 128) in
+ let pos = ref 0 in
+ begin try
+ while true do
+ if !pos = bytes_length !buf then begin
+ let newbuf = bytes_create (2 * !pos) in
+ bytes_blit !buf 0 newbuf 0 !pos;
+ buf := newbuf
+ end;
+ let c = input_char ic in
+ if c = '\n' then raise Exit;
+ bytes_set !buf !pos c;
+ incr pos
+ done
+ with Exit -> ()
+ | End_of_file -> if !pos = 0 then raise End_of_file
+ end;
+ let res = bytes_create !pos in
+ bytes_blit !buf 0 res 0 !pos;
+ bytes_unsafe_to_string res
+
+let rec input_byte ic =
+ try
+ input_byte_blocking ic
+ with Sys_blocked_io ->
+ wait_inchan ic; input_byte ic
+
+let input_binary_int ic =
+ let b1 = input_byte ic in
+ let n1 = if b1 >= 128 then b1 - 256 else b1 in
+ let b2 = input_byte ic in
+ let b3 = input_byte ic in
+ let b4 = input_byte ic in
+ (n1 lsl 24) + (b2 lsl 16) + (b3 lsl 8) + b4
+
+external unmarshal : bytes -> int -> 'a = "caml_input_value_from_string"
+external marshal_data_size : bytes -> int -> int = "caml_marshal_data_size"
+
+let input_value ic =
+ let header = bytes_create 20 in
+ really_input ic header 0 20;
+ let bsize = marshal_data_size header 0 in
+ let buffer = bytes_create (20 + bsize) in
+ bytes_blit header 0 buffer 0 20;
+ really_input ic buffer 20 bsize;
+ unmarshal buffer 0
+
+external seek_in : in_channel -> int -> unit = "caml_ml_seek_in"
+external pos_in : in_channel -> int = "caml_ml_pos_in"
+external in_channel_length : in_channel -> int = "caml_ml_channel_size"
+external close_in : in_channel -> unit = "caml_ml_close_channel"
+let close_in_noerr ic = (try close_in ic with _ -> ())
+external set_binary_mode_in : in_channel -> bool -> unit
+ = "caml_ml_set_binary_mode"
+
+(* Output functions on standard output *)
+
+let print_char c = output_char stdout c
+let print_string s = output_string stdout s
+let print_bytes s = output_bytes stdout s
+let print_int i = output_string stdout (string_of_int i)
+let print_float f = output_string stdout (string_of_float f)
+let print_endline s =
+ output_string stdout s; output_char stdout '\n'; flush stdout
+let print_newline () = output_char stdout '\n'; flush stdout
+
+(* Output functions on standard error *)
+
+let prerr_char c = output_char stderr c
+let prerr_string s = output_string stderr s
+let prerr_bytes s = output_bytes stderr s
+let prerr_int i = output_string stderr (string_of_int i)
+let prerr_float f = output_string stderr (string_of_float f)
+let prerr_endline s =
+ output_string stderr s; output_char stderr '\n'; flush stderr
+let prerr_newline () = output_char stderr '\n'; flush stderr
+
+(* Input functions on standard input *)
+
+let read_line () = flush stdout; input_line stdin
+let read_int () = int_of_string(read_line())
+let read_int_opt () = int_of_string_opt(read_line())
+let read_float () = float_of_string(read_line())
+let read_float_opt () = float_of_string_opt(read_line())
+
+(* Operations on large files *)
+
+module LargeFile =
+ struct
+ external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64"
+ external pos_out : out_channel -> int64 = "caml_ml_pos_out_64"
+ external out_channel_length : out_channel -> int64
+ = "caml_ml_channel_size_64"
+ external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64"
+ external pos_in : in_channel -> int64 = "caml_ml_pos_in_64"
+ external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64"
+ end
+
+(* Formats *)
+
+type ('a, 'b, 'c, 'd, 'e, 'f) format6
+ = ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
+ = Format of ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt
+ * string
+
+type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
+
+type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
+
+let string_of_format (Format (_fmt, str)) = str
+
+external format_of_string :
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
+
+let ( ^^ ) (Format (fmt1, str1)) (Format (fmt2, str2)) =
+ Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2,
+ str1 ^ "%," ^ str2)
+
+(* Miscellaneous *)
+
+external sys_exit : int -> 'a = "caml_sys_exit"
+
+let exit_function = ref flush_all
+
+let at_exit f =
+ let g = !exit_function in
+ (* MPR#7253, MPR#7796: make sure "f" is executed only once *)
+ let f_already_ran = ref false in
+ exit_function :=
+ (fun () ->
+ if not !f_already_ran then begin f_already_ran := true; f() end;
+ g())
+
+let do_at_exit () = (!exit_function) ()
+
+let exit retcode =
+ do_at_exit ();
+ sys_exit retcode
+
+let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
+end
+
+include Pervasives
+
+(*MODULE_ALIASES*)
+module Arg = Arg
+module Array = Array
+module ArrayLabels = ArrayLabels
+module Bigarray = Bigarray
+module Buffer = Buffer
+module Bytes = Bytes
+module BytesLabels = BytesLabels
+module Callback = Callback
+module Char = Char
+module Complex = Complex
+module Digest = Digest
+module Ephemeron = Ephemeron
+module Filename = Filename
+module Float = Float
+module Format = Format
+module Gc = Gc
+module Genlex = Genlex
+module Hashtbl = Hashtbl
+module Int32 = Int32
+module Int64 = Int64
+module Lazy = Lazy
+module Lexing = Lexing
+module List = List
+module ListLabels = ListLabels
+module Map = Map
+module Marshal = Marshal
+module MoreLabels = MoreLabels
+module Nativeint = Nativeint
+module Obj = Obj
+module Oo = Oo
+module Parsing = Parsing
+module Printexc = Printexc
+module Printf = Printf
+module Queue = Queue
+module Random = Random
+module Scanf = Scanf
+module Seq = Seq
+module Set = Set
+module Sort = Sort
+module Spacetime = Spacetime
+module Stack = Stack
+module StdLabels = StdLabels
+module Stream = Stream
+module String = String
+module StringLabels = StringLabels
+module Sys = Sys
+module Uchar = Uchar
+module Weak = Weak
val wait_write : Unix.file_descr -> unit
(** Suspend the execution of the calling thread until at least
- one character is available for reading ({!Thread.wait_read}) or
+ one character or EOF is available for reading ({!Thread.wait_read}) or
one character can be written without blocking ([wait_write])
on the given Unix file descriptor. *)
end
external map_internal:
- file_descr -> ('a, 'b) CamlinternalBigarray.kind
- -> 'c CamlinternalBigarray.layout
+ file_descr -> ('a, 'b) Stdlib.Bigarray.kind
+ -> 'c Stdlib.Bigarray.layout
-> bool -> int array -> int64
- -> ('a, 'b, 'c) CamlinternalBigarray.genarray
+ -> ('a, 'b, 'c) Stdlib.Bigarray.Genarray.t
= "caml_unix_map_file_bytecode" "caml_unix_map_file"
let map_file fd ?(pos=0L) kind layout shared dims =
#include <caml/alloc.h>
#include <caml/memory.h>
#include "unixsupport.h"
+#include <errno.h>
#include <stdio.h>
#include <grp.h>
{
struct group * entry;
if (! caml_string_is_c_safe(name)) caml_raise_not_found();
+ errno = 0;
entry = getgrnam(String_val(name));
- if (entry == NULL) caml_raise_not_found();
+ if (entry == NULL) {
+ if (errno == EINTR) {
+ uerror("getgrnam", Nothing);
+ } else {
+ caml_raise_not_found();
+ }
+ }
return alloc_group_entry(entry);
}
CAMLprim value unix_getgrgid(value gid)
{
struct group * entry;
+ errno = 0;
entry = getgrgid(Int_val(gid));
- if (entry == NULL) caml_raise_not_found();
+ if (entry == NULL) {
+ if (errno == EINTR) {
+ uerror("getgrgid", Nothing);
+ } else {
+ caml_raise_not_found();
+ }
+ }
return alloc_group_entry(entry);
}
#include <caml/memory.h>
#include <caml/fail.h>
#include "unixsupport.h"
+#include <errno.h>
#include <pwd.h>
static value alloc_passwd_entry(struct passwd *entry)
{
struct passwd * entry;
if (! caml_string_is_c_safe(name)) caml_raise_not_found();
+ errno = 0;
entry = getpwnam(String_val(name));
- if (entry == (struct passwd *) NULL) caml_raise_not_found();
+ if (entry == (struct passwd *) NULL) {
+ if (errno == EINTR) {
+ uerror("getpwnam", Nothing);
+ } else {
+ caml_raise_not_found();
+ }
+ }
return alloc_passwd_entry(entry);
}
CAMLprim value unix_getpwuid(value uid)
{
struct passwd * entry;
+ errno = 0;
entry = getpwuid(Int_val(uid));
- if (entry == (struct passwd *) NULL) caml_raise_not_found();
+ if (entry == (struct passwd *) NULL) {
+ if (errno == EINTR) {
+ uerror("getpwuid", Nothing);
+ } else {
+ caml_raise_not_found();
+ }
+ }
return alloc_passwd_entry(entry);
}
end
external map_internal:
- file_descr -> ('a, 'b) CamlinternalBigarray.kind
- -> 'c CamlinternalBigarray.layout
+ file_descr -> ('a, 'b) Stdlib.Bigarray.kind
+ -> 'c Stdlib.Bigarray.layout
-> bool -> int array -> int64
- -> ('a, 'b, 'c) CamlinternalBigarray.genarray
+ -> ('a, 'b, 'c) Stdlib.Bigarray.Genarray.t
= "caml_unix_map_file_bytecode" "caml_unix_map_file"
let map_file fd ?(pos=0L) kind layout shared dims =
(** {6 Mapping files into memory} *)
val map_file :
- file_descr -> ?pos:int64 -> ('a, 'b) CamlinternalBigarray.kind ->
- 'c CamlinternalBigarray.layout -> bool -> int array ->
- ('a, 'b, 'c) CamlinternalBigarray.genarray
+ file_descr -> ?pos:int64 -> ('a, 'b) Stdlib.Bigarray.kind ->
+ 'c Stdlib.Bigarray.layout -> bool -> int array ->
+ ('a, 'b, 'c) Stdlib.Bigarray.Genarray.t
(** Memory mapping of a file as a big array.
[map_file fd kind layout shared dims]
returns a big array of kind [kind], layout [layout],
(** {1 Mapping files into memory} *)
val map_file :
- file_descr -> ?pos:int64 -> kind:('a, 'b) CamlinternalBigarray.kind ->
- layout:'c CamlinternalBigarray.layout -> shared:bool -> dims:int array ->
- ('a, 'b, 'c) CamlinternalBigarray.genarray
+ file_descr -> ?pos:int64 -> kind:('a, 'b) Stdlib.Bigarray.kind ->
+ layout:'c Stdlib.Bigarray.layout -> shared:bool -> dims:int array ->
+ ('a, 'b, 'c) Stdlib.Bigarray.Genarray.t
(** Memory mapping of a file as a big array.
[map_file fd kind layout shared dims]
returns a big array of kind [kind], layout [layout],
val getpwnam : string -> passwd_entry
(** Find an entry in [passwd] with the given name, or raise
- [Not_found]. *)
+ [Not_found] if the matching entry is not found. *)
val getgrnam : string -> group_entry
(** Find an entry in [group] with the given name, or raise
- [Not_found]. *)
+ [Not_found] if the matching entry is not found. *)
val getpwuid : int -> passwd_entry
(** Find an entry in [passwd] with the given user id, or raise
- [Not_found]. *)
+ [Not_found] if the matching entry is not found. *)
val getgrgid : int -> group_entry
(** Find an entry in [group] with the given group id, or raise
- [Not_found]. *)
+ [Not_found] if the matching entry is not found. *)
(** {1 Internet addresses} *)
#elif defined(HAS_UTIME)
#include <sys/types.h>
-#ifndef _WIN32
#include <utime.h>
-#else
-#include <sys/utime.h>
-#endif
CAMLprim value unix_utimes(value path, value atime, value mtime)
{
CAMLparam3(path, atime, mtime);
-#ifdef _WIN32
- struct _utimbuf times, * t;
-#else
struct utimbuf times, * t;
-#endif
- char_os * p;
+ char * p;
int ret;
double at, mt;
caml_unix_check_path(path, "utimes");
times.modtime = mt;
t = ×
}
- p = caml_stat_strdup_to_os(String_val(path));
+ p = caml_stat_strdup(String_val(path));
caml_enter_blocking_section();
- ret = utime_os(p, t);
+ ret = utime(p, t);
caml_leave_blocking_section();
caml_stat_free(p);
if (ret == -1) uerror("utimes", path);
break;
}
caml_gr_handle_event(msg, wParam, lParam);
- return DefWindowProc(hwnd, msg, wParam, lParam);
+ return DefWindowProcA(hwnd, msg, wParam, lParam);
}
int DoRegisterClass(void)
select.c sendrecv.c \
shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \
symlink.c system.c times.c unixsupport.c windir.c winwait.c write.c \
- winlist.c winworker.c windbug.c
+ winlist.c winworker.c windbug.c utimes.c
# Files from the ../unix directory
UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \
exit.c getaddrinfo.c getcwd.c gethost.c gethostname.c \
getnameinfo.c getproto.c \
getserv.c gmtime.c mmap_ba.c putenv.c rmdir.c \
- socketaddr.c strofaddr.c time.c unlink.c utimes.c
+ socketaddr.c strofaddr.c time.c unlink.c
UNIX_CAML_FILES = unix.mli unixLabels.mli unixLabels.ml
ALL_FILES=$(WIN_FILES) $(UNIX_FILES)
-WSOCKLIB=$(call SYSLIB,ws2_32)
-ADVAPI32LIB=$(call SYSLIB,advapi32)
LIBNAME=unix
COBJS=$(ALL_FILES:.c=.$(O))
CAMLOBJS=unix.cmo unixLabels.cmo
-LINKOPTS=-cclib $(WSOCKLIB) -cclib $(ADVAPI32LIB)
-LDOPTS=-ldopt $(WSOCKLIB) -ldopt $(ADVAPI32LIB)
+WIN32_LIBS=$(call SYSLIB,ws2_32) $(call SYSLIB,advapi32)
+LINKOPTS=$(addprefix -cclib ,$(WIN32_LIBS))
EXTRACAMLFLAGS=-nolabels
EXTRACFLAGS=-I../unix
HEADERS=unixsupport.h socketaddr.h
include ../Makefile
+ifeq "$(SYSTEM)" "mingw"
+LDOPTS=-ldopt "-link -static-libgcc" $(addprefix -ldopt ,$(WIN32_LIBS))
+else
+LDOPTS=$(addprefix -ldopt ,$(WIN32_LIBS))
+endif
+
clean::
rm -f $(UNIX_FILES) $(UNIX_CAML_FILES)
#include <fcntl.h>
#include <io.h>
-#if defined(_MSC_VER) && !defined(_INTPTR_T_DEFINED)
-typedef int intptr_t;
-#define _INTPTR_T_DEFINED
-#endif
-
int win_CRT_fd_of_filedescr(value handle)
{
if (CRT_fd_val(handle) != NO_CRT_FD) {
#include <caml/memory.h>
#include <caml/osdeps.h>
-#include <Windows.h>
-#include <stdlib.h>
+#include <windows.h>
+/* Win32 doesn't have a notion of setuid bit. */
CAMLprim value unix_environment(value unit)
{
- /* Win32 doesn't have a notion of setuid bit, so accessing environ is safe. */
- if (_wenviron != NULL) {
- return caml_alloc_array((void *)caml_copy_string_of_utf16, (const char**)_wenviron);
- } else {
- return Atom(0);
+ CAMLparam0();
+ CAMLlocal2(v, result);
+ wchar_t * envp, * p;
+ int size, i;
+
+ envp = GetEnvironmentStrings();
+ for (p = envp, size = 0; *p; p += wcslen(p) + 1) size++;
+ result = caml_alloc(size, 0);
+ for (p = envp, i = 0; *p; p += wcslen(p) + 1) {
+ v = caml_copy_string_of_utf16(p);
+ Store_field(result, i ++, v);
}
+ FreeEnvironmentStrings(envp);
+
+ CAMLreturn(result);
}
/* */
/**************************************************************************/
+#define CAML_INTERNALS
+
#include <caml/mlvalues.h>
+#include <caml/osdeps.h>
#include "unixsupport.h"
CAMLprim value unix_isatty(value fd)
{
- DWORD lpMode;
- HANDLE hFile = Handle_val(fd);
- return (Val_bool((GetFileType(hFile) == FILE_TYPE_CHAR)
- && GetConsoleMode(hFile, &lpMode)));
+ return Val_bool(caml_win32_isatty(win_CRT_fd_of_filedescr(fd)));
}
ULARGE_INTEGER utime = {{time->dwLowDateTime, time->dwHighDateTime}};
if (utime.QuadPart) {
- /* There are 11644473600000 seconds between 1 January 1601 (the NT Epoch)
- * and 1 January 1970 (the Unix Epoch). FILETIME is measured in 100ns ticks.
+ /* There are 11644473600 seconds between 1 January 1601 (the NT Epoch) and 1
+ * January 1970 (the Unix Epoch). FILETIME is measured in 100ns ticks.
*/
*result = (utime.QuadPart - INT64_LITERAL(116444736000000000U));
}
(* Mapping files into memory *)
external map_internal:
- file_descr -> ('a, 'b) CamlinternalBigarray.kind
- -> 'c CamlinternalBigarray.layout
+ file_descr -> ('a, 'b) Stdlib.Bigarray.kind
+ -> 'c Stdlib.Bigarray.layout
-> bool -> int array -> int64
- -> ('a, 'b, 'c) CamlinternalBigarray.genarray
+ -> ('a, 'b, 'c) Stdlib.Bigarray.Genarray.t
= "caml_unix_map_file_bytecode" "caml_unix_map_file"
let map_file fd ?(pos=0L) kind layout shared dims =
--- /dev/null
+/**************************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Nicolas Ojeda Bar, LexiFi */
+/* */
+/* Copyright 2017 Institut National de Recherche en Informatique et */
+/* en Automatique. */
+/* */
+/* All rights reserved. This file is distributed under the terms of */
+/* the GNU Lesser General Public License version 2.1, with the */
+/* special exception on linking described in the file LICENSE. */
+/* */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include <caml/osdeps.h>
+#include "unixsupport.h"
+
+#include <windows.h>
+
+static void convert_time(double unixTime, FILETIME* ft)
+{
+ ULARGE_INTEGER u;
+ /* There are 11644473600 seconds between 1 January 1601 (the NT Epoch) and 1
+ * January 1970 (the Unix Epoch). FILETIME is measured in 100ns ticks.
+ */
+ u.QuadPart = (ULONGLONG)(unixTime * 10000000.0) + INT64_LITERAL(116444736000000000U);
+ ft->dwLowDateTime = u.LowPart;
+ ft->dwHighDateTime = u.HighPart;
+}
+
+CAMLprim value unix_utimes(value path, value atime, value mtime)
+{
+ CAMLparam3(path, atime, mtime);
+ WCHAR *wpath;
+ HANDLE hFile;
+ FILETIME lastAccessTime, lastModificationTime;
+ SYSTEMTIME systemTime;
+ double at, mt;
+ BOOL res;
+
+ caml_unix_check_path(path, "utimes");
+ at = Double_val(atime);
+ mt = Double_val(mtime);
+ wpath = caml_stat_strdup_to_utf16(String_val(path));
+ caml_enter_blocking_section();
+ hFile = CreateFile(wpath,
+ FILE_WRITE_ATTRIBUTES,
+ FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, 0, NULL);
+ caml_leave_blocking_section();
+ caml_stat_free(wpath);
+ if (hFile == INVALID_HANDLE_VALUE) {
+ win32_maperr(GetLastError());
+ uerror("utimes", path);
+ }
+ if (at == 0.0 && mt == 0.0) {
+ GetSystemTime(&systemTime);
+ SystemTimeToFileTime(&systemTime, &lastAccessTime);
+ memcpy(&lastModificationTime, &lastAccessTime, sizeof(FILETIME));
+ } else {
+ convert_time(at, &lastAccessTime);
+ convert_time(mt, &lastModificationTime);
+ }
+ caml_enter_blocking_section();
+ res = SetFileTime(hFile, NULL, &lastAccessTime, &lastModificationTime);
+ caml_leave_blocking_section();
+ if (res == 0) {
+ win32_maperr(GetLastError());
+ CloseHandle(hFile);
+ uerror("utimes", path);
+ }
+ CloseHandle(hFile);
+ CAMLreturn(Val_unit);
+}
let err = Syntaxerr.ill_formed_ast
let empty_record loc = err loc "Records cannot be empty."
-let empty_variant loc = err loc "Variant types cannot be empty."
let invalid_tuple loc = err loc "Tuples must have at least 2 components."
let no_args loc = err loc "Function application with no argument."
let empty_let loc = err loc "Let with no bindings."
let loc = td.ptype_loc in
match td.ptype_kind with
| Ptype_record [] -> empty_record loc
- | Ptype_variant [] -> empty_variant loc
| _ -> ()
in
let typ self ty =
let add = add_parent
-let addmodule bv lid = add_path bv lid.txt
+let add_module_path bv lid = add_path bv lid.txt
let handle_extension ext =
match (fst ext).txt with
| Pexp_object { pcstr_self = pat; pcstr_fields = fieldl } ->
let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
| Pexp_newtype (_, e) -> add_expr bv e
- | Pexp_pack m -> add_module bv m
+ | Pexp_pack m -> add_module_expr bv m
| Pexp_open (_ovf, m, e) ->
let bv = open_module bv m.txt in add_expr bv e
| Pexp_extension (({ txt = ("ocaml.extension_constructor"|
and add_modtype bv mty =
match mty.pmty_desc with
Pmty_ident l -> add bv l
- | Pmty_alias l -> addmodule bv l
+ | Pmty_alias l -> add_module_path bv l
| Pmty_signature s -> add_signature bv s
| Pmty_functor(id, mty1, mty2) ->
Misc.may (add_modtype bv) mty1;
List.iter
(function
| Pwith_type (_, td) -> add_type_declaration bv td
- | Pwith_module (_, lid) -> addmodule bv lid
+ | Pwith_module (_, lid) -> add_module_path bv lid
| Pwith_typesubst (_, td) -> add_type_declaration bv td
- | Pwith_modsubst (_, lid) -> addmodule bv lid
+ | Pwith_modsubst (_, lid) -> add_module_path bv lid
)
cstrl
- | Pmty_typeof m -> add_module bv m
+ | Pmty_typeof m -> add_module_expr bv m
| Pmty_extension e -> handle_extension e
and add_module_alias bv l =
+ (* If we are in delayed dependencies mode, we delay the dependencies
+ induced by "Lident s" *)
+ (if !Clflags.transparent_modules then add_parent else add_module_path) bv l;
try
- add_parent bv l;
lookup_map l.txt bv
with Not_found ->
match l.txt with
Lident s -> make_leaf s
- | _ -> addmodule bv l; bound (* cannot delay *)
+ | _ -> add_module_path bv l; bound (* cannot delay *)
and add_modtype_binding bv mty =
- if not !Clflags.transparent_modules then add_modtype bv mty;
match mty.pmty_desc with
Pmty_alias l ->
add_module_alias bv l
| Pmty_typeof modl ->
add_module_binding bv modl
| _ ->
- if !Clflags.transparent_modules then add_modtype bv mty; bound
+ add_modtype bv mty; bound
and add_signature bv sg =
ignore (add_signature_binding bv sg)
(bv, m)
and add_module_binding bv modl =
- if not !Clflags.transparent_modules then add_module bv modl;
match modl.pmod_desc with
- Pmod_ident l ->
- begin try
- add_parent bv l;
- lookup_map l.txt bv
- with Not_found ->
- match l.txt with
- Lident s -> make_leaf s
- | _ -> addmodule bv l; bound
- end
+ Pmod_ident l -> add_module_alias bv l
| Pmod_structure s ->
- make_node (snd (add_structure_binding bv s))
- | _ ->
- if !Clflags.transparent_modules then add_module bv modl; bound
+ make_node (snd @@ add_structure_binding bv s)
+ | _ -> add_module_expr bv modl; bound
-and add_module bv modl =
+and add_module_expr bv modl =
match modl.pmod_desc with
- Pmod_ident l -> addmodule bv l
+ Pmod_ident l -> add_module_path bv l
| Pmod_structure s -> ignore (add_structure bv s)
| Pmod_functor(id, mty, modl) ->
Misc.may (add_modtype bv) mty;
- add_module (StringMap.add id.txt bound bv) modl
+ add_module_expr (StringMap.add id.txt bound bv) modl
| Pmod_apply(mod1, mod2) ->
- add_module bv mod1; add_module bv mod2
+ add_module_expr bv mod1; add_module_expr bv mod2
| Pmod_constraint(modl, mty) ->
- add_module bv modl; add_modtype bv mty
+ add_module_expr bv modl; add_modtype bv mty
| Pmod_unpack(e) ->
add_expr bv e
| Pmod_extension e ->
in
let bv' = add bv and m = add m in
List.iter
- (fun x -> add_module bv' x.pmb_expr)
+ (fun x -> add_module_expr bv' x.pmb_expr)
bindings;
(bv', m)
| Pstr_modtype x ->
| Pstr_class_type cdtl ->
List.iter (add_class_type_declaration bv) cdtl; (bv, m)
| Pstr_include incl ->
- let Node (s, m') = add_module_binding bv incl.pincl_mod in
- add_names s;
+ let Node (s, m') as n = add_module_binding bv incl.pincl_mod in
+ if !Clflags.transparent_modules then
+ add_names s
+ else
+ (* If we are not in the delayed dependency mode, we need to
+ collect all delayed dependencies imported by the include statement *)
+ add_names (collect_free n);
let add = StringMap.fold StringMap.add m' in
(add bv, add m)
| Pstr_attribute _ -> (bv, m)
ignore (List.fold_left add_top_phrase bv top_phrs)
and add_implementation bv l =
- if !Clflags.transparent_modules then
ignore (add_structure_binding bv l)
- else ignore (add_structure bv l)
and add_implementation_binding bv l =
snd (add_structure_binding bv l)
get_docstrings dsl
with Not_found -> []
+let get_post_text pos =
+ try
+ let dsl = Hashtbl.find post_table pos in
+ get_docstrings dsl
+ with Not_found -> []
+
(* Maps from positions to extra docstrings *)
let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t =
let rhs_text pos =
get_text (Parsing.rhs_start_pos pos)
+let rhs_post_text pos =
+ get_post_text (Parsing.rhs_end_pos pos)
+
let rhs_text_lazy pos =
let pos = Parsing.rhs_start_pos pos in
lazy (get_text pos)
(** Fetch additional text following the symbol at the given position *)
val rhs_post_extra_text : int -> text
+
+(** Fetch text following the symbol at the given position *)
+val rhs_post_text : int -> text
lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 };
STAR
}
- | ("#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
- ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"")?) as directive
- [^ '\010' '\013'] * newline
- {
- match int_of_string num with
- | exception _ ->
- (* PR#7165 *)
- let loc = Location.curr lexbuf in
- let explanation = "line number out of range" in
- let error = Invalid_directive (directive, Some explanation) in
- raise (Error (error, loc))
- | line_num ->
- (* Documentation says that the line number should be
- positive, but we have never guarded against this and it
- might have useful hackish uses. *)
- update_loc lexbuf name line_num true 0;
- token lexbuf
+ | "#"
+ { let at_beginning_of_line pos = (pos.pos_cnum = pos.pos_bol) in
+ if not (at_beginning_of_line lexbuf.lex_start_p)
+ then HASH
+ else try directive lexbuf with Failure _ -> HASH
}
- | "#" { HASH }
| "&" { AMPERSAND }
| "&&" { AMPERAMPER }
| "`" { BACKQUOTE }
Location.curr lexbuf))
}
+and directive = parse
+ | ([' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
+ ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"") as directive)
+ [^ '\010' '\013'] *
+ {
+ match int_of_string num with
+ | exception _ ->
+ (* PR#7165 *)
+ let loc = Location.curr lexbuf in
+ let explanation = "line number out of range" in
+ let error = Invalid_directive ("#" ^ directive, Some explanation) in
+ raise (Error (error, loc))
+ | line_num ->
+ (* Documentation says that the line number should be
+ positive, but we have never guarded against this and it
+ might have useful hackish uses. *)
+ update_loc lexbuf (Some name) (line_num - 1) true 0;
+ token lexbuf
+ }
and comment = parse
"(*"
{ comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc;
(* Highlight the locations using standout mode. *)
-let highlight_terminfo ppf num_lines lb locs =
+let highlight_terminfo ppf lb locs =
Format.pp_print_flush ppf (); (* avoid mixing Format and normal output *)
(* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
let pos0 = -lb.lex_abs_pos in
if Bytes.get lb.lex_buffer i = '\n' then incr lines
done;
(* If too many lines, give up *)
- if !lines >= num_lines - 2 then raise Exit;
+ if !lines >= Terminfo.num_lines stdout - 2 then raise Exit;
(* Move cursor up that number of lines *)
- flush stdout; Terminfo.backup !lines;
+ flush stdout; Terminfo.backup stdout !lines;
(* Print the input, switching to standout for the location *)
let bol = ref false in
print_string "# ";
for pos = 0 to lb.lex_buffer_len - pos0 - 1 do
if !bol then (print_string " "; bol := false);
if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then
- Terminfo.standout true;
+ Terminfo.standout stdout true;
if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then
- Terminfo.standout false;
+ Terminfo.standout stdout false;
let c = Bytes.get lb.lex_buffer (pos + pos0) in
print_char c;
bol := (c = '\n')
done;
(* Make sure standout mode is over *)
- Terminfo.standout false;
+ Terminfo.standout stdout false;
(* Position cursor back to original location *)
- Terminfo.resume !num_loc_lines;
+ Terminfo.resume stdout !num_loc_lines;
flush stdout
(* Highlight the location by printing it again. *)
-let highlight_dumb ppf lb loc =
+let highlight_dumb ~print_chars ppf lb loc =
(* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
let pos0 = -lb.lex_abs_pos in
(* Do nothing if the buffer does not contain the whole phrase. *)
if loc.loc_end.pos_cnum > pos then incr line_end;
end
done;
+ Format.fprintf ppf "@[<v>";
(* Print character location (useful for Emacs) *)
- Format.fprintf ppf "@[<v>Characters %i-%i:@,"
- loc.loc_start.pos_cnum loc.loc_end.pos_cnum;
+ if print_chars then begin
+ Format.fprintf ppf "Characters %i-%i:@,"
+ loc.loc_start.pos_cnum loc.loc_end.pos_cnum
+ end;
(* Print the input, underlining the location *)
Format.pp_print_string ppf " ";
let line = ref 0 in
done;
Format.fprintf ppf "@]"
+let show_code_at_location ppf lb loc =
+ highlight_dumb ~print_chars:false ppf lb loc
+
(* Highlight the location using one of the supported modes. *)
let rec highlight_locations ppf locs =
try Sys.getenv "TERM" = "norepeat" with Not_found -> false in
if norepeat then false else
let loc1 = List.hd locs in
- try highlight_dumb ppf lb loc1; true
+ try highlight_dumb ~print_chars:true ppf lb loc1; true
with Exit -> false
end
- | Terminfo.Good_term num_lines ->
+ | Terminfo.Good_term ->
begin match !input_lexbuf with
None -> false
| Some lb ->
- try highlight_terminfo ppf num_lines lb locs; true
+ try highlight_terminfo ppf lb locs; true
with Exit -> false
end
open Format
+let rewrite_absolute_path =
+ let init = ref false in
+ let map_cache = ref None in
+ fun path ->
+ if not !init then begin
+ init := true;
+ match Sys.getenv "BUILD_PATH_PREFIX_MAP" with
+ | exception Not_found -> ()
+ | encoded_map ->
+ match Build_path_prefix_map.decode_map encoded_map with
+ | Error err ->
+ Misc.fatal_errorf
+ "Invalid value for the environment variable \
+ BUILD_PATH_PREFIX_MAP: %s" err
+ | Ok map -> map_cache := Some map
+ end;
+ match !map_cache with
+ | None -> path
+ | Some map -> Build_path_prefix_map.rewrite map path
+
let absolute_path s = (* This function could go into Filename *)
let open Filename in
- let s = if is_relative s then concat (Sys.getcwd ()) s else s in
+ let s =
+ if not (is_relative s) then s
+ else (rewrite_absolute_path (concat (Sys.getcwd ()) s))
+ in
(* Now simplify . and .. components *)
let rec aux s =
let base = basename s in
val get_pos_info: Lexing.position -> string * int * int (* file, line, char *)
val print_loc: formatter -> t -> unit
+val print_error_prefix: formatter -> unit
val print_error: formatter -> t -> unit
val print_error_cur_file: formatter -> unit -> unit
val print_warning: t -> formatter -> Warnings.t -> unit
val highlight_locations: formatter -> t list -> bool
+val show_code_at_location: formatter -> Lexing.lexbuf -> t -> unit
+
type 'a loc = {
txt : 'a;
loc : t;
val print_compact: formatter -> t -> unit
val print_filename: formatter -> string -> unit
+val rewrite_absolute_path: string -> string
+ (** rewrite absolute path to honor the BUILD_PATH_PREFIX_MAP
+ variable (https://reproducible-builds.org/specs/build-path-prefix-map/)
+ if it is set. *)
+
val absolute_path: string -> string
val show_filename: string -> string
let text_def pos = [Ptop_def (Str.text (rhs_text pos))]
let extra_text text pos items =
- let pre_extras = rhs_pre_extra_text pos in
- let post_extras = rhs_post_extra_text pos in
- text pre_extras @ items @ text post_extras
+ match items with
+ | [] ->
+ let post = rhs_post_text pos in
+ let post_extras = rhs_post_extra_text pos in
+ text post @ text post_extras
+ | _ :: _ ->
+ let pre_extras = rhs_pre_extra_text pos in
+ let post_extras = rhs_post_extra_text pos in
+ text pre_extras @ items @ text post_extras
let extra_str pos items = extra_text Str.text pos items
let extra_sig pos items = extra_text Sig.text pos items
| structure_item top_structure_tail { (text_str 1) @ $1 :: $2 }
;
use_file:
- use_file_body { extra_def 1 $1 }
+ use_file_body EOF { extra_def 1 $1 }
;
use_file_body:
use_file_tail { $1 }
{ (text_def 1) @ Ptop_def[mkstrexp $1 $2] :: $3 }
;
use_file_tail:
- EOF
+ /* empty */
{ [] }
- | SEMISEMI EOF
- { text_def 1 }
- | SEMISEMI seq_expr post_item_attributes use_file_tail
- { mark_rhs_docs 2 3;
- (text_def 1) @ (text_def 2) @ Ptop_def[mkstrexp $2 $3] :: $4 }
- | SEMISEMI structure_item use_file_tail
- { (text_def 1) @ (text_def 2) @ Ptop_def[$2] :: $3 }
- | SEMISEMI toplevel_directive use_file_tail
- { mark_rhs_docs 2 3;
- (text_def 1) @ (text_def 2) @ $2 :: $3 }
+ | SEMISEMI use_file_body
+ { $2 }
| structure_item use_file_tail
{ (text_def 1) @ Ptop_def[$1] :: $2 }
| toplevel_directive use_file_tail
| type_parameter_list COMMA type_parameter { $3 :: $1 }
;
constructor_declarations:
- constructor_declaration { [$1] }
+ | BAR { [ ] }
+ | constructor_declaration { [$1] }
| bar_constructor_declaration { [$1] }
| constructor_declarations bar_constructor_declaration { $2 :: $1 }
;
and type_kind =
| Ptype_abstract
| Ptype_variant of constructor_declaration list
- (* Invariant: non-empty list *)
| Ptype_record of label_declaration list
(* Invariant: non-empty list *)
| Ptype_open
(attributes ctxt) x.pmty_attributes
end else
match x.pmty_desc with
- | Pmty_ident li ->
- pp f "%a" longident_loc li;
- | Pmty_alias li ->
- pp f "(module %a)" longident_loc li;
- | Pmty_signature (s) ->
- pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
- (list (signature_item ctxt)) s (* FIXME wrong indentation*)
| Pmty_functor (_, None, mt2) ->
pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2
| Pmty_functor (s, Some mt1, mt2) ->
if s.txt = "_" then
pp f "@[<hov2>%a@ ->@ %a@]"
- (module_type ctxt) mt1 (module_type ctxt) mt2
+ (module_type1 ctxt) mt1 (module_type ctxt) mt2
else
pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
(module_type ctxt) mt1 (module_type ctxt) mt2
+ | Pmty_with (mt, []) -> module_type ctxt f mt
| Pmty_with (mt, l) ->
let with_constraint f = function
| Pwith_type (li, ({ptype_params= ls ;_} as td)) ->
(type_declaration ctxt) td
| Pwith_modsubst (li, li2) ->
pp f "module %a :=@ %a" longident_loc li longident_loc li2 in
- (match l with
- | [] -> pp f "@[<hov2>%a@]" (module_type ctxt) mt
- | _ -> pp f "@[<hov2>(%a@ with@ %a)@]"
- (module_type ctxt) mt (list with_constraint ~sep:"@ and@ ") l)
+ pp f "@[<hov2>%a@ with@ %a@]"
+ (module_type1 ctxt) mt (list with_constraint ~sep:"@ and@ ") l
+ | _ -> module_type1 ctxt f x
+
+and module_type1 ctxt f x =
+ if x.pmty_attributes <> [] then module_type ctxt f x
+ else match x.pmty_desc with
+ | Pmty_ident li ->
+ pp f "%a" longident_loc li;
+ | Pmty_alias li ->
+ pp f "(module %a)" longident_loc li;
+ | Pmty_signature (s) ->
+ pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
+ (list (signature_item ctxt)) s (* FIXME wrong indentation*)
| Pmty_typeof me ->
pp f "@[<hov2>module@ type@ of@ %a@]" (module_expr ctxt) me
| Pmty_extension e -> extension ctxt f e
+ | _ -> paren true (module_type ctxt) f x
and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x
| pmd :: tl ->
if not first then
pp f "@ @[<hov2>and@ %s:@ %a@]%a" pmd.pmd_name.txt
- (module_type ctxt) pmd.pmd_type
+ (module_type1 ctxt) pmd.pmd_type
(item_attributes ctxt) pmd.pmd_attributes
else
pp f "@[<hov2>module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt
- (module_type ctxt) pmd.pmd_type
+ (module_type1 ctxt) pmd.pmd_type
(item_attributes ctxt) pmd.pmd_attributes;
string_x_module_type_list f ~first:false tl
in
in
match x.ptype_kind with
| Ptype_variant xs ->
- pp f "%t%t@\n%a" intro priv
- (list ~sep:"@\n" constructor_declaration) xs
+ let variants fmt xs =
+ if xs = [] then pp fmt " |" else
+ pp fmt "@\n%a" (list ~sep:"@\n" constructor_declaration) xs
+ in pp f "%t%t%a" intro priv variants xs
| Ptype_abstract -> ()
| Ptype_record l ->
pp f "%t%t@;%a" intro priv (record_declaration ctxt) l
-arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \
- arg.cmi
-arg.cmx : sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx \
- arg.cmi
-arg.cmi :
-array.cmo : array.cmi
-array.cmx : array.cmi
-array.cmi :
-arrayLabels.cmo : array.cmi arrayLabels.cmi
-arrayLabels.cmx : array.cmx arrayLabels.cmi
-arrayLabels.cmi :
-buffer.cmo : uchar.cmi sys.cmi string.cmi char.cmi bytes.cmi buffer.cmi
-buffer.cmx : uchar.cmx sys.cmx string.cmx char.cmx bytes.cmx buffer.cmi
-buffer.cmi : uchar.cmi
-bytes.cmo : pervasives.cmi char.cmi bytes.cmi
-bytes.cmx : pervasives.cmx char.cmx bytes.cmi
-bytes.cmi :
-bytesLabels.cmo : bytes.cmi bytesLabels.cmi
-bytesLabels.cmx : bytes.cmx bytesLabels.cmi
-bytesLabels.cmi :
-callback.cmo : obj.cmi callback.cmi
-callback.cmx : obj.cmx callback.cmi
-callback.cmi :
-camlinternalBigarray.cmo : complex.cmi
-camlinternalBigarray.cmx : complex.cmx
-camlinternalFormat.cmo : sys.cmi string.cmi char.cmi \
- camlinternalFormatBasics.cmi bytes.cmi buffer.cmi camlinternalFormat.cmi
-camlinternalFormat.cmx : sys.cmx string.cmx char.cmx \
- camlinternalFormatBasics.cmx bytes.cmx buffer.cmx camlinternalFormat.cmi
-camlinternalFormat.cmi : camlinternalFormatBasics.cmi buffer.cmi
+stdlib__arg.cmo : stdlib__sys.cmi stdlib__string.cmi stdlib__printf.cmi stdlib__list.cmi stdlib__buffer.cmi stdlib__array.cmi \
+ stdlib__arg.cmi
+stdlib__arg.cmx : stdlib__sys.cmx stdlib__string.cmx stdlib__printf.cmx stdlib__list.cmx stdlib__buffer.cmx stdlib__array.cmx \
+ stdlib__arg.cmi
+stdlib__arg.cmi :
+stdlib__array.cmo : stdlib__seq.cmi stdlib__array.cmi
+stdlib__array.cmx : stdlib__seq.cmx stdlib__array.cmi
+stdlib__array.cmi : stdlib__seq.cmi
+stdlib__arrayLabels.cmo : stdlib__array.cmi stdlib__arrayLabels.cmi
+stdlib__arrayLabels.cmx : stdlib__array.cmx stdlib__arrayLabels.cmi
+stdlib__arrayLabels.cmi : stdlib__seq.cmi
+stdlib__bigarray.cmo : stdlib__sys.cmi stdlib__complex.cmi stdlib__array.cmi stdlib__bigarray.cmi
+stdlib__bigarray.cmx : stdlib__sys.cmx stdlib__complex.cmx stdlib__array.cmx stdlib__bigarray.cmi
+stdlib__bigarray.cmi : stdlib__complex.cmi
+stdlib__buffer.cmo : stdlib__uchar.cmi stdlib__sys.cmi stdlib__string.cmi stdlib__seq.cmi stdlib__char.cmi stdlib__bytes.cmi \
+ stdlib__buffer.cmi
+stdlib__buffer.cmx : stdlib__uchar.cmx stdlib__sys.cmx stdlib__string.cmx stdlib__seq.cmx stdlib__char.cmx stdlib__bytes.cmx \
+ stdlib__buffer.cmi
+stdlib__buffer.cmi : stdlib__uchar.cmi stdlib__seq.cmi
+stdlib__bytes.cmo : stdlib__sys.cmi stdlib__seq.cmi stdlib__char.cmi stdlib__bytes.cmi
+stdlib__bytes.cmx : stdlib__sys.cmx stdlib__seq.cmx stdlib__char.cmx stdlib__bytes.cmi
+stdlib__bytes.cmi : stdlib__seq.cmi
+stdlib__bytesLabels.cmo : stdlib__bytes.cmi stdlib__bytesLabels.cmi
+stdlib__bytesLabels.cmx : stdlib__bytes.cmx stdlib__bytesLabels.cmi
+stdlib__bytesLabels.cmi : stdlib__seq.cmi
+stdlib__callback.cmo : stdlib__obj.cmi stdlib__callback.cmi
+stdlib__callback.cmx : stdlib__obj.cmx stdlib__callback.cmi
+stdlib__callback.cmi :
+camlinternalFormat.cmo : stdlib__sys.cmi stdlib__string.cmi stdlib__char.cmi \
+ camlinternalFormatBasics.cmi stdlib__bytes.cmi stdlib__buffer.cmi camlinternalFormat.cmi
+camlinternalFormat.cmx : stdlib__sys.cmx stdlib__string.cmx stdlib__char.cmx \
+ camlinternalFormatBasics.cmx stdlib__bytes.cmx stdlib__buffer.cmx camlinternalFormat.cmi
+camlinternalFormat.cmi : camlinternalFormatBasics.cmi stdlib__buffer.cmi
camlinternalFormatBasics.cmo : camlinternalFormatBasics.cmi
camlinternalFormatBasics.cmx : camlinternalFormatBasics.cmi
camlinternalFormatBasics.cmi :
-camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi
-camlinternalLazy.cmx : obj.cmx camlinternalLazy.cmi
+camlinternalLazy.cmo : stdlib__obj.cmi camlinternalLazy.cmi
+camlinternalLazy.cmx : stdlib__obj.cmx camlinternalLazy.cmi
camlinternalLazy.cmi :
-camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \
+camlinternalMod.cmo : stdlib__obj.cmi camlinternalOO.cmi stdlib__array.cmi \
camlinternalMod.cmi
-camlinternalMod.cmx : obj.cmx camlinternalOO.cmx array.cmx \
+camlinternalMod.cmx : stdlib__obj.cmx camlinternalOO.cmx stdlib__array.cmx \
camlinternalMod.cmi
-camlinternalMod.cmi : obj.cmi
-camlinternalOO.cmo : sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
- array.cmi camlinternalOO.cmi
-camlinternalOO.cmx : sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \
- array.cmx camlinternalOO.cmi
-camlinternalOO.cmi : obj.cmi
-char.cmo : char.cmi
-char.cmx : char.cmi
-char.cmi :
-complex.cmo : complex.cmi
-complex.cmx : complex.cmi
-complex.cmi :
-digest.cmo : string.cmi char.cmi bytes.cmi digest.cmi
-digest.cmx : string.cmx char.cmx bytes.cmx digest.cmi
-digest.cmi :
-ephemeron.cmo : sys.cmi random.cmi obj.cmi lazy.cmi hashtbl.cmi array.cmi \
- ephemeron.cmi
-ephemeron.cmx : sys.cmx random.cmx obj.cmx lazy.cmx hashtbl.cmx array.cmx \
- ephemeron.cmi
-ephemeron.cmi : hashtbl.cmi
-filename.cmo : sys.cmi string.cmi random.cmi printf.cmi lazy.cmi buffer.cmi \
- filename.cmi
-filename.cmx : sys.cmx string.cmx random.cmx printf.cmx lazy.cmx buffer.cmx \
- filename.cmi
-filename.cmi :
-format.cmo : string.cmi pervasives.cmi list.cmi camlinternalFormatBasics.cmi \
- camlinternalFormat.cmi buffer.cmi format.cmi
-format.cmx : string.cmx pervasives.cmx list.cmx camlinternalFormatBasics.cmx \
- camlinternalFormat.cmx buffer.cmx format.cmi
-format.cmi : pervasives.cmi buffer.cmi
-gc.cmo : sys.cmi string.cmi printf.cmi gc.cmi
-gc.cmx : sys.cmx string.cmx printf.cmx gc.cmi
-gc.cmi :
-genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi bytes.cmi \
- genlex.cmi
-genlex.cmx : string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx bytes.cmx \
- genlex.cmi
-genlex.cmi : stream.cmi
-hashtbl.cmo : sys.cmi string.cmi random.cmi obj.cmi lazy.cmi array.cmi \
- hashtbl.cmi
-hashtbl.cmx : sys.cmx string.cmx random.cmx obj.cmx lazy.cmx array.cmx \
- hashtbl.cmi
-hashtbl.cmi :
-int32.cmo : pervasives.cmi int32.cmi
-int32.cmx : pervasives.cmx int32.cmi
-int32.cmi :
-int64.cmo : pervasives.cmi int64.cmi
-int64.cmx : pervasives.cmx int64.cmi
-int64.cmi :
-lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi
-lazy.cmx : obj.cmx camlinternalLazy.cmx lazy.cmi
-lazy.cmi :
-lexing.cmo : sys.cmi string.cmi bytes.cmi array.cmi lexing.cmi
-lexing.cmx : sys.cmx string.cmx bytes.cmx array.cmx lexing.cmi
-lexing.cmi :
-list.cmo : list.cmi
-list.cmx : list.cmi
-list.cmi :
-listLabels.cmo : list.cmi listLabels.cmi
-listLabels.cmx : list.cmx listLabels.cmi
-listLabels.cmi :
-map.cmo : map.cmi
-map.cmx : map.cmi
-map.cmi :
-marshal.cmo : bytes.cmi marshal.cmi
-marshal.cmx : bytes.cmx marshal.cmi
-marshal.cmi :
-moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi
-moreLabels.cmx : set.cmx map.cmx hashtbl.cmx moreLabels.cmi
-moreLabels.cmi : set.cmi map.cmi hashtbl.cmi
-nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi
-nativeint.cmx : sys.cmx pervasives.cmx nativeint.cmi
-nativeint.cmi :
-obj.cmo : marshal.cmi int32.cmi obj.cmi
-obj.cmx : marshal.cmx int32.cmx obj.cmi
-obj.cmi : int32.cmi
-oo.cmo : camlinternalOO.cmi oo.cmi
-oo.cmx : camlinternalOO.cmx oo.cmi
-oo.cmi : camlinternalOO.cmi
-parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi
-parsing.cmx : obj.cmx lexing.cmx array.cmx parsing.cmi
-parsing.cmi : obj.cmi lexing.cmi
-pervasives.cmo : camlinternalFormatBasics.cmi pervasives.cmi
-pervasives.cmx : camlinternalFormatBasics.cmx pervasives.cmi
-pervasives.cmi : camlinternalFormatBasics.cmi
-printexc.cmo : printf.cmi pervasives.cmi obj.cmi buffer.cmi array.cmi \
- printexc.cmi
-printexc.cmx : printf.cmx pervasives.cmx obj.cmx buffer.cmx array.cmx \
- printexc.cmi
-printexc.cmi :
-printf.cmo : camlinternalFormatBasics.cmi camlinternalFormat.cmi buffer.cmi \
- printf.cmi
-printf.cmx : camlinternalFormatBasics.cmx camlinternalFormat.cmx buffer.cmx \
- printf.cmi
-printf.cmi : buffer.cmi
-queue.cmo : queue.cmi
-queue.cmx : queue.cmi
-queue.cmi :
-random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
- digest.cmi char.cmi array.cmi random.cmi
-random.cmx : string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \
- digest.cmx char.cmx array.cmx random.cmi
-random.cmi : nativeint.cmi int64.cmi int32.cmi
-scanf.cmo : string.cmi printf.cmi pervasives.cmi list.cmi \
- camlinternalFormatBasics.cmi camlinternalFormat.cmi bytes.cmi buffer.cmi \
- scanf.cmi
-scanf.cmx : string.cmx printf.cmx pervasives.cmx list.cmx \
- camlinternalFormatBasics.cmx camlinternalFormat.cmx bytes.cmx buffer.cmx \
- scanf.cmi
-scanf.cmi : pervasives.cmi
-set.cmo : list.cmi set.cmi
-set.cmx : list.cmx set.cmi
-set.cmi :
-sort.cmo : array.cmi sort.cmi
-sort.cmx : array.cmx sort.cmi
-sort.cmi :
-spacetime.cmo : gc.cmi spacetime.cmi
-spacetime.cmx : gc.cmx spacetime.cmi
-spacetime.cmi :
-stack.cmo : list.cmi stack.cmi
-stack.cmx : list.cmx stack.cmi
-stack.cmi :
-stdLabels.cmo : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
- arrayLabels.cmi stdLabels.cmi
-stdLabels.cmx : stringLabels.cmx listLabels.cmx bytesLabels.cmx \
- arrayLabels.cmx stdLabels.cmi
-stdLabels.cmi : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
- arrayLabels.cmi
+camlinternalMod.cmi : stdlib__obj.cmi
+camlinternalOO.cmo : stdlib__sys.cmi stdlib__string.cmi stdlib__obj.cmi stdlib__map.cmi stdlib__list.cmi stdlib__char.cmi \
+ stdlib__array.cmi camlinternalOO.cmi
+camlinternalOO.cmx : stdlib__sys.cmx stdlib__string.cmx stdlib__obj.cmx stdlib__map.cmx stdlib__list.cmx stdlib__char.cmx \
+ stdlib__array.cmx camlinternalOO.cmi
+camlinternalOO.cmi : stdlib__obj.cmi
+stdlib__char.cmo : stdlib__char.cmi
+stdlib__char.cmx : stdlib__char.cmi
+stdlib__char.cmi :
+stdlib__complex.cmo : stdlib__complex.cmi
+stdlib__complex.cmx : stdlib__complex.cmi
+stdlib__complex.cmi :
+stdlib__digest.cmo : stdlib__string.cmi stdlib__char.cmi stdlib__bytes.cmi stdlib__digest.cmi
+stdlib__digest.cmx : stdlib__string.cmx stdlib__char.cmx stdlib__bytes.cmx stdlib__digest.cmi
+stdlib__digest.cmi :
+stdlib__ephemeron.cmo : stdlib__sys.cmi stdlib__seq.cmi stdlib__random.cmi stdlib__obj.cmi stdlib__lazy.cmi stdlib__hashtbl.cmi \
+ stdlib__array.cmi stdlib__ephemeron.cmi
+stdlib__ephemeron.cmx : stdlib__sys.cmx stdlib__seq.cmx stdlib__random.cmx stdlib__obj.cmx stdlib__lazy.cmx stdlib__hashtbl.cmx \
+ stdlib__array.cmx stdlib__ephemeron.cmi
+stdlib__ephemeron.cmi : stdlib__hashtbl.cmi
+stdlib__filename.cmo : stdlib__sys.cmi stdlib__string.cmi stdlib__random.cmi stdlib__printf.cmi stdlib__lazy.cmi stdlib__buffer.cmi \
+ stdlib__filename.cmi
+stdlib__filename.cmx : stdlib__sys.cmx stdlib__string.cmx stdlib__random.cmx stdlib__printf.cmx stdlib__lazy.cmx stdlib__buffer.cmx \
+ stdlib__filename.cmi
+stdlib__filename.cmi :
+stdlib__float.cmo : stdlib__float.cmi
+stdlib__float.cmx : stdlib__float.cmi
+stdlib__float.cmi :
+stdlib__format.cmo : stdlib__string.cmi stdlib__list.cmi camlinternalFormatBasics.cmi \
+ camlinternalFormat.cmi stdlib__buffer.cmi stdlib__format.cmi
+stdlib__format.cmx : stdlib__string.cmx stdlib__list.cmx camlinternalFormatBasics.cmx \
+ camlinternalFormat.cmx stdlib__buffer.cmx stdlib__format.cmi
+stdlib__format.cmi : stdlib__buffer.cmi
+stdlib__gc.cmo : stdlib__sys.cmi stdlib__string.cmi stdlib__printf.cmi stdlib__gc.cmi
+stdlib__gc.cmx : stdlib__sys.cmx stdlib__string.cmx stdlib__printf.cmx stdlib__gc.cmi
+stdlib__gc.cmi :
+stdlib__genlex.cmo : stdlib__string.cmi stdlib__stream.cmi stdlib__list.cmi stdlib__hashtbl.cmi stdlib__char.cmi stdlib__bytes.cmi \
+ stdlib__genlex.cmi
+stdlib__genlex.cmx : stdlib__string.cmx stdlib__stream.cmx stdlib__list.cmx stdlib__hashtbl.cmx stdlib__char.cmx stdlib__bytes.cmx \
+ stdlib__genlex.cmi
+stdlib__genlex.cmi : stdlib__stream.cmi
+stdlib__hashtbl.cmo : stdlib__sys.cmi stdlib__string.cmi stdlib__seq.cmi stdlib__random.cmi stdlib__obj.cmi stdlib__lazy.cmi \
+ stdlib__array.cmi stdlib__hashtbl.cmi
+stdlib__hashtbl.cmx : stdlib__sys.cmx stdlib__string.cmx stdlib__seq.cmx stdlib__random.cmx stdlib__obj.cmx stdlib__lazy.cmx \
+ stdlib__array.cmx stdlib__hashtbl.cmi
+stdlib__hashtbl.cmi : stdlib__seq.cmi
+stdlib__int32.cmo : stdlib__int32.cmi
+stdlib__int32.cmx : stdlib__int32.cmi
+stdlib__int32.cmi :
+stdlib__int64.cmo : stdlib__int64.cmi
+stdlib__int64.cmx : stdlib__int64.cmi
+stdlib__int64.cmi :
+stdlib__lazy.cmo : stdlib__obj.cmi camlinternalLazy.cmi stdlib__lazy.cmi
+stdlib__lazy.cmx : stdlib__obj.cmx camlinternalLazy.cmx stdlib__lazy.cmi
+stdlib__lazy.cmi :
+stdlib__lexing.cmo : stdlib__sys.cmi stdlib__string.cmi stdlib__bytes.cmi stdlib__array.cmi stdlib__lexing.cmi
+stdlib__lexing.cmx : stdlib__sys.cmx stdlib__string.cmx stdlib__bytes.cmx stdlib__array.cmx stdlib__lexing.cmi
+stdlib__lexing.cmi :
+stdlib__list.cmo : stdlib__sys.cmi stdlib__seq.cmi stdlib__list.cmi
+stdlib__list.cmx : stdlib__sys.cmx stdlib__seq.cmx stdlib__list.cmi
+stdlib__list.cmi : stdlib__seq.cmi
+stdlib__listLabels.cmo : stdlib__list.cmi stdlib__listLabels.cmi
+stdlib__listLabels.cmx : stdlib__list.cmx stdlib__listLabels.cmi
+stdlib__listLabels.cmi : stdlib__seq.cmi
+stdlib__map.cmo : stdlib__seq.cmi stdlib__map.cmi
+stdlib__map.cmx : stdlib__seq.cmx stdlib__map.cmi
+stdlib__map.cmi : stdlib__seq.cmi
+stdlib__marshal.cmo : stdlib__bytes.cmi stdlib__marshal.cmi
+stdlib__marshal.cmx : stdlib__bytes.cmx stdlib__marshal.cmi
+stdlib__marshal.cmi :
+stdlib__moreLabels.cmo : stdlib__set.cmi stdlib__map.cmi stdlib__hashtbl.cmi stdlib__moreLabels.cmi
+stdlib__moreLabels.cmx : stdlib__set.cmx stdlib__map.cmx stdlib__hashtbl.cmx stdlib__moreLabels.cmi
+stdlib__moreLabels.cmi : stdlib__set.cmi stdlib__seq.cmi stdlib__map.cmi stdlib__hashtbl.cmi
+stdlib__nativeint.cmo : stdlib__sys.cmi stdlib__nativeint.cmi
+stdlib__nativeint.cmx : stdlib__sys.cmx stdlib__nativeint.cmi
+stdlib__nativeint.cmi :
+stdlib__obj.cmo : stdlib__marshal.cmi stdlib__int32.cmi stdlib__obj.cmi
+stdlib__obj.cmx : stdlib__marshal.cmx stdlib__int32.cmx stdlib__obj.cmi
+stdlib__obj.cmi : stdlib__int32.cmi
+stdlib__oo.cmo : camlinternalOO.cmi stdlib__oo.cmi
+stdlib__oo.cmx : camlinternalOO.cmx stdlib__oo.cmi
+stdlib__oo.cmi : camlinternalOO.cmi
+stdlib__parsing.cmo : stdlib__obj.cmi stdlib__lexing.cmi stdlib__array.cmi stdlib__parsing.cmi
+stdlib__parsing.cmx : stdlib__obj.cmx stdlib__lexing.cmx stdlib__array.cmx stdlib__parsing.cmi
+stdlib__parsing.cmi : stdlib__obj.cmi stdlib__lexing.cmi
+stdlib__printexc.cmo : stdlib__printf.cmi stdlib__obj.cmi stdlib__buffer.cmi stdlib__array.cmi stdlib__printexc.cmi
+stdlib__printexc.cmx : stdlib__printf.cmx stdlib__obj.cmx stdlib__buffer.cmx stdlib__array.cmx stdlib__printexc.cmi
+stdlib__printexc.cmi :
+stdlib__printf.cmo : camlinternalFormatBasics.cmi camlinternalFormat.cmi stdlib__buffer.cmi \
+ stdlib__printf.cmi
+stdlib__printf.cmx : camlinternalFormatBasics.cmx camlinternalFormat.cmx stdlib__buffer.cmx \
+ stdlib__printf.cmi
+stdlib__printf.cmi : stdlib__buffer.cmi
+stdlib__queue.cmo : stdlib__seq.cmi stdlib__queue.cmi
+stdlib__queue.cmx : stdlib__seq.cmx stdlib__queue.cmi
+stdlib__queue.cmi : stdlib__seq.cmi
+stdlib__random.cmo : stdlib__string.cmi stdlib__nativeint.cmi stdlib__int64.cmi stdlib__int32.cmi stdlib__digest.cmi \
+ stdlib__char.cmi stdlib__array.cmi stdlib__random.cmi
+stdlib__random.cmx : stdlib__string.cmx stdlib__nativeint.cmx stdlib__int64.cmx stdlib__int32.cmx stdlib__digest.cmx \
+ stdlib__char.cmx stdlib__array.cmx stdlib__random.cmi
+stdlib__random.cmi : stdlib__nativeint.cmi stdlib__int64.cmi stdlib__int32.cmi
+stdlib__scanf.cmo : stdlib__string.cmi stdlib__printf.cmi stdlib__list.cmi camlinternalFormatBasics.cmi \
+ camlinternalFormat.cmi stdlib__bytes.cmi stdlib__buffer.cmi stdlib__scanf.cmi
+stdlib__scanf.cmx : stdlib__string.cmx stdlib__printf.cmx stdlib__list.cmx camlinternalFormatBasics.cmx \
+ camlinternalFormat.cmx stdlib__bytes.cmx stdlib__buffer.cmx stdlib__scanf.cmi
+stdlib__scanf.cmi :
+stdlib__seq.cmo : stdlib__seq.cmi
+stdlib__seq.cmx : stdlib__seq.cmi
+stdlib__seq.cmi :
+stdlib__set.cmo : stdlib__seq.cmi stdlib__list.cmi stdlib__set.cmi
+stdlib__set.cmx : stdlib__seq.cmx stdlib__list.cmx stdlib__set.cmi
+stdlib__set.cmi : stdlib__seq.cmi
+stdlib__sort.cmo : stdlib__array.cmi stdlib__sort.cmi
+stdlib__sort.cmx : stdlib__array.cmx stdlib__sort.cmi
+stdlib__sort.cmi :
+stdlib__spacetime.cmo : stdlib__gc.cmi stdlib__spacetime.cmi
+stdlib__spacetime.cmx : stdlib__gc.cmx stdlib__spacetime.cmi
+stdlib__spacetime.cmi :
+stdlib__stack.cmo : stdlib__seq.cmi stdlib__list.cmi stdlib__stack.cmi
+stdlib__stack.cmx : stdlib__seq.cmx stdlib__list.cmx stdlib__stack.cmi
+stdlib__stack.cmi : stdlib__seq.cmi
+stdlib__stdLabels.cmo : stdlib__stringLabels.cmi stdlib__listLabels.cmi stdlib__bytesLabels.cmi \
+ stdlib__arrayLabels.cmi stdlib__stdLabels.cmi
+stdlib__stdLabels.cmx : stdlib__stringLabels.cmx stdlib__listLabels.cmx stdlib__bytesLabels.cmx \
+ stdlib__arrayLabels.cmx stdlib__stdLabels.cmi
+stdlib__stdLabels.cmi : stdlib__stringLabels.cmi stdlib__listLabels.cmi stdlib__bytesLabels.cmi \
+ stdlib__arrayLabels.cmi
std_exit.cmo :
std_exit.cmx :
-stream.cmo : string.cmi list.cmi lazy.cmi bytes.cmi stream.cmi
-stream.cmx : string.cmx list.cmx lazy.cmx bytes.cmx stream.cmi
-stream.cmi :
-string.cmo : pervasives.cmi bytes.cmi string.cmi
-string.cmx : pervasives.cmx bytes.cmx string.cmi
-string.cmi :
-stringLabels.cmo : string.cmi stringLabels.cmi
-stringLabels.cmx : string.cmx stringLabels.cmi
-stringLabels.cmi :
-sys.cmo : sys.cmi
-sys.cmx : sys.cmi
-sys.cmi :
-uchar.cmo : pervasives.cmi char.cmi uchar.cmi
-uchar.cmx : pervasives.cmx char.cmx uchar.cmi
-uchar.cmi :
-weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
-weak.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi
-weak.cmi : hashtbl.cmi
-arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \
- arg.cmi
-arg.p.cmx : sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx \
- arg.cmi
-array.cmo : array.cmi
-array.p.cmx : array.cmi
-arrayLabels.cmo : array.cmi arrayLabels.cmi
-arrayLabels.p.cmx : array.cmx arrayLabels.cmi
-buffer.cmo : uchar.cmi sys.cmi string.cmi char.cmi bytes.cmi buffer.cmi
-buffer.p.cmx : uchar.cmx sys.cmx string.cmx char.cmx bytes.cmx buffer.cmi
-bytes.cmo : pervasives.cmi char.cmi bytes.cmi
-bytes.p.cmx : pervasives.cmx char.cmx bytes.cmi
-bytesLabels.cmo : bytes.cmi bytesLabels.cmi
-bytesLabels.p.cmx : bytes.cmx bytesLabels.cmi
-callback.cmo : obj.cmi callback.cmi
-callback.p.cmx : obj.cmx callback.cmi
-camlinternalBigarray.cmo : complex.cmi
-camlinternalBigarray.p.cmx : complex.cmx
-camlinternalFormat.cmo : sys.cmi string.cmi char.cmi \
- camlinternalFormatBasics.cmi bytes.cmi buffer.cmi camlinternalFormat.cmi
-camlinternalFormat.p.cmx : sys.cmx string.cmx char.cmx \
- camlinternalFormatBasics.cmx bytes.cmx buffer.cmx camlinternalFormat.cmi
+stdlib__stream.cmo : stdlib__string.cmi stdlib__list.cmi stdlib__lazy.cmi stdlib__bytes.cmi stdlib__stream.cmi
+stdlib__stream.cmx : stdlib__string.cmx stdlib__list.cmx stdlib__lazy.cmx stdlib__bytes.cmx stdlib__stream.cmi
+stdlib__stream.cmi :
+stdlib__string.cmo : stdlib__bytes.cmi stdlib__string.cmi
+stdlib__string.cmx : stdlib__bytes.cmx stdlib__string.cmi
+stdlib__string.cmi : stdlib__seq.cmi
+stdlib__stringLabels.cmo : stdlib__string.cmi stdlib__stringLabels.cmi
+stdlib__stringLabels.cmx : stdlib__string.cmx stdlib__stringLabels.cmi
+stdlib__stringLabels.cmi : stdlib__seq.cmi
+stdlib__sys.cmo : stdlib__sys.cmi
+stdlib__sys.cmx : stdlib__sys.cmi
+stdlib__sys.cmi :
+stdlib__uchar.cmo : stdlib__char.cmi stdlib__uchar.cmi
+stdlib__uchar.cmx : stdlib__char.cmx stdlib__uchar.cmi
+stdlib__uchar.cmi :
+stdlib__weak.cmo : stdlib__sys.cmi stdlib__obj.cmi stdlib__hashtbl.cmi stdlib__array.cmi stdlib__weak.cmi
+stdlib__weak.cmx : stdlib__sys.cmx stdlib__obj.cmx stdlib__hashtbl.cmx stdlib__array.cmx stdlib__weak.cmi
+stdlib__weak.cmi : stdlib__hashtbl.cmi
+stdlib.cmo : camlinternalFormatBasics.cmi stdlib.cmi
+stdlib.cmx : camlinternalFormatBasics.cmx stdlib.cmi
+stdlib.cmi : camlinternalFormatBasics.cmi
+stdlib__arg.cmo : stdlib__sys.cmi stdlib__string.cmi stdlib__printf.cmi stdlib__list.cmi stdlib__buffer.cmi stdlib__array.cmi \
+ stdlib__arg.cmi
+stdlib__arg.p.cmx : stdlib__sys.cmx stdlib__string.cmx stdlib__printf.cmx stdlib__list.cmx stdlib__buffer.cmx stdlib__array.cmx \
+ stdlib__arg.cmi
+stdlib__array.cmo : stdlib__seq.cmi stdlib__array.cmi
+stdlib__array.p.cmx : stdlib__seq.cmx stdlib__array.cmi
+stdlib__arrayLabels.cmo : stdlib__array.cmi stdlib__arrayLabels.cmi
+stdlib__arrayLabels.p.cmx : stdlib__array.cmx stdlib__arrayLabels.cmi
+stdlib__bigarray.cmo : stdlib__sys.cmi stdlib__complex.cmi stdlib__array.cmi stdlib__bigarray.cmi
+stdlib__bigarray.p.cmx : stdlib__sys.cmx stdlib__complex.cmx stdlib__array.cmx stdlib__bigarray.cmi
+stdlib__buffer.cmo : stdlib__uchar.cmi stdlib__sys.cmi stdlib__string.cmi stdlib__seq.cmi stdlib__char.cmi stdlib__bytes.cmi \
+ stdlib__buffer.cmi
+stdlib__buffer.p.cmx : stdlib__uchar.cmx stdlib__sys.cmx stdlib__string.cmx stdlib__seq.cmx stdlib__char.cmx stdlib__bytes.cmx \
+ stdlib__buffer.cmi
+stdlib__bytes.cmo : stdlib__sys.cmi stdlib__seq.cmi stdlib__char.cmi stdlib__bytes.cmi
+stdlib__bytes.p.cmx : stdlib__sys.cmx stdlib__seq.cmx stdlib__char.cmx stdlib__bytes.cmi
+stdlib__bytesLabels.cmo : stdlib__bytes.cmi stdlib__bytesLabels.cmi
+stdlib__bytesLabels.p.cmx : stdlib__bytes.cmx stdlib__bytesLabels.cmi
+stdlib__callback.cmo : stdlib__obj.cmi stdlib__callback.cmi
+stdlib__callback.p.cmx : stdlib__obj.cmx stdlib__callback.cmi
+camlinternalFormat.cmo : stdlib__sys.cmi stdlib__string.cmi stdlib__char.cmi \
+ camlinternalFormatBasics.cmi stdlib__bytes.cmi stdlib__buffer.cmi camlinternalFormat.cmi
+camlinternalFormat.p.cmx : stdlib__sys.cmx stdlib__string.cmx stdlib__char.cmx \
+ camlinternalFormatBasics.cmx stdlib__bytes.cmx stdlib__buffer.cmx camlinternalFormat.cmi
camlinternalFormatBasics.cmo : camlinternalFormatBasics.cmi
camlinternalFormatBasics.p.cmx : camlinternalFormatBasics.cmi
-camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi
-camlinternalLazy.p.cmx : obj.cmx camlinternalLazy.cmi
-camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \
+camlinternalLazy.cmo : stdlib__obj.cmi camlinternalLazy.cmi
+camlinternalLazy.p.cmx : stdlib__obj.cmx camlinternalLazy.cmi
+camlinternalMod.cmo : stdlib__obj.cmi camlinternalOO.cmi stdlib__array.cmi \
camlinternalMod.cmi
-camlinternalMod.p.cmx : obj.cmx camlinternalOO.cmx array.cmx \
+camlinternalMod.p.cmx : stdlib__obj.cmx camlinternalOO.cmx stdlib__array.cmx \
camlinternalMod.cmi
-camlinternalOO.cmo : sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
- array.cmi camlinternalOO.cmi
-camlinternalOO.p.cmx : sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \
- array.cmx camlinternalOO.cmi
-char.cmo : char.cmi
-char.p.cmx : char.cmi
-complex.cmo : complex.cmi
-complex.p.cmx : complex.cmi
-digest.cmo : string.cmi char.cmi bytes.cmi digest.cmi
-digest.p.cmx : string.cmx char.cmx bytes.cmx digest.cmi
-ephemeron.cmo : sys.cmi random.cmi obj.cmi lazy.cmi hashtbl.cmi array.cmi \
- ephemeron.cmi
-ephemeron.p.cmx : sys.cmx random.cmx obj.cmx lazy.cmx hashtbl.cmx array.cmx \
- ephemeron.cmi
-filename.cmo : sys.cmi string.cmi random.cmi printf.cmi lazy.cmi buffer.cmi \
- filename.cmi
-filename.p.cmx : sys.cmx string.cmx random.cmx printf.cmx lazy.cmx buffer.cmx \
- filename.cmi
-format.cmo : string.cmi pervasives.cmi list.cmi camlinternalFormatBasics.cmi \
- camlinternalFormat.cmi buffer.cmi format.cmi
-format.p.cmx : string.cmx pervasives.cmx list.cmx camlinternalFormatBasics.cmx \
- camlinternalFormat.cmx buffer.cmx format.cmi
-gc.cmo : sys.cmi string.cmi printf.cmi gc.cmi
-gc.p.cmx : sys.cmx string.cmx printf.cmx gc.cmi
-genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi bytes.cmi \
- genlex.cmi
-genlex.p.cmx : string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx bytes.cmx \
- genlex.cmi
-hashtbl.cmo : sys.cmi string.cmi random.cmi obj.cmi lazy.cmi array.cmi \
- hashtbl.cmi
-hashtbl.p.cmx : sys.cmx string.cmx random.cmx obj.cmx lazy.cmx array.cmx \
- hashtbl.cmi
-int32.cmo : pervasives.cmi int32.cmi
-int32.p.cmx : pervasives.cmx int32.cmi
-int64.cmo : pervasives.cmi int64.cmi
-int64.p.cmx : pervasives.cmx int64.cmi
-lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi
-lazy.p.cmx : obj.cmx camlinternalLazy.cmx lazy.cmi
-lexing.cmo : sys.cmi string.cmi bytes.cmi array.cmi lexing.cmi
-lexing.p.cmx : sys.cmx string.cmx bytes.cmx array.cmx lexing.cmi
-list.cmo : list.cmi
-list.p.cmx : list.cmi
-listLabels.cmo : list.cmi listLabels.cmi
-listLabels.p.cmx : list.cmx listLabels.cmi
-map.cmo : map.cmi
-map.p.cmx : map.cmi
-marshal.cmo : bytes.cmi marshal.cmi
-marshal.p.cmx : bytes.cmx marshal.cmi
-moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi
-moreLabels.p.cmx : set.cmx map.cmx hashtbl.cmx moreLabels.cmi
-nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi
-nativeint.p.cmx : sys.cmx pervasives.cmx nativeint.cmi
-obj.cmo : marshal.cmi int32.cmi obj.cmi
-obj.p.cmx : marshal.cmx int32.cmx obj.cmi
-oo.cmo : camlinternalOO.cmi oo.cmi
-oo.p.cmx : camlinternalOO.cmx oo.cmi
-parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi
-parsing.p.cmx : obj.cmx lexing.cmx array.cmx parsing.cmi
-pervasives.cmo : camlinternalFormatBasics.cmi pervasives.cmi
-pervasives.p.cmx : camlinternalFormatBasics.cmx pervasives.cmi
-printexc.cmo : printf.cmi pervasives.cmi obj.cmi buffer.cmi array.cmi \
- printexc.cmi
-printexc.p.cmx : printf.cmx pervasives.cmx obj.cmx buffer.cmx array.cmx \
- printexc.cmi
-printf.cmo : camlinternalFormatBasics.cmi camlinternalFormat.cmi buffer.cmi \
- printf.cmi
-printf.p.cmx : camlinternalFormatBasics.cmx camlinternalFormat.cmx buffer.cmx \
- printf.cmi
-queue.cmo : queue.cmi
-queue.p.cmx : queue.cmi
-random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
- digest.cmi char.cmi array.cmi random.cmi
-random.p.cmx : string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \
- digest.cmx char.cmx array.cmx random.cmi
-scanf.cmo : string.cmi printf.cmi pervasives.cmi list.cmi \
- camlinternalFormatBasics.cmi camlinternalFormat.cmi bytes.cmi buffer.cmi \
- scanf.cmi
-scanf.p.cmx : string.cmx printf.cmx pervasives.cmx list.cmx \
- camlinternalFormatBasics.cmx camlinternalFormat.cmx bytes.cmx buffer.cmx \
- scanf.cmi
-set.cmo : list.cmi set.cmi
-set.p.cmx : list.cmx set.cmi
-sort.cmo : array.cmi sort.cmi
-sort.p.cmx : array.cmx sort.cmi
-spacetime.cmo : gc.cmi spacetime.cmi
-spacetime.p.cmx : gc.cmx spacetime.cmi
-stack.cmo : list.cmi stack.cmi
-stack.p.cmx : list.cmx stack.cmi
-stdLabels.cmo : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
- arrayLabels.cmi stdLabels.cmi
-stdLabels.p.cmx : stringLabels.cmx listLabels.cmx bytesLabels.cmx \
- arrayLabels.cmx stdLabels.cmi
+camlinternalOO.cmo : stdlib__sys.cmi stdlib__string.cmi stdlib__obj.cmi stdlib__map.cmi stdlib__list.cmi stdlib__char.cmi \
+ stdlib__array.cmi camlinternalOO.cmi
+camlinternalOO.p.cmx : stdlib__sys.cmx stdlib__string.cmx stdlib__obj.cmx stdlib__map.cmx stdlib__list.cmx stdlib__char.cmx \
+ stdlib__array.cmx camlinternalOO.cmi
+stdlib__char.cmo : stdlib__char.cmi
+stdlib__char.p.cmx : stdlib__char.cmi
+stdlib__complex.cmo : stdlib__complex.cmi
+stdlib__complex.p.cmx : stdlib__complex.cmi
+stdlib__digest.cmo : stdlib__string.cmi stdlib__char.cmi stdlib__bytes.cmi stdlib__digest.cmi
+stdlib__digest.p.cmx : stdlib__string.cmx stdlib__char.cmx stdlib__bytes.cmx stdlib__digest.cmi
+stdlib__ephemeron.cmo : stdlib__sys.cmi stdlib__seq.cmi stdlib__random.cmi stdlib__obj.cmi stdlib__lazy.cmi stdlib__hashtbl.cmi \
+ stdlib__array.cmi stdlib__ephemeron.cmi
+stdlib__ephemeron.p.cmx : stdlib__sys.cmx stdlib__seq.cmx stdlib__random.cmx stdlib__obj.cmx stdlib__lazy.cmx stdlib__hashtbl.cmx \
+ stdlib__array.cmx stdlib__ephemeron.cmi
+stdlib__filename.cmo : stdlib__sys.cmi stdlib__string.cmi stdlib__random.cmi stdlib__printf.cmi stdlib__lazy.cmi stdlib__buffer.cmi \
+ stdlib__filename.cmi
+stdlib__filename.p.cmx : stdlib__sys.cmx stdlib__string.cmx stdlib__random.cmx stdlib__printf.cmx stdlib__lazy.cmx stdlib__buffer.cmx \
+ stdlib__filename.cmi
+stdlib__float.cmo : stdlib__float.cmi
+stdlib__float.p.cmx : stdlib__float.cmi
+stdlib__format.cmo : stdlib__string.cmi stdlib__list.cmi camlinternalFormatBasics.cmi \
+ camlinternalFormat.cmi stdlib__buffer.cmi stdlib__format.cmi
+stdlib__format.p.cmx : stdlib__string.cmx stdlib__list.cmx camlinternalFormatBasics.cmx \
+ camlinternalFormat.cmx stdlib__buffer.cmx stdlib__format.cmi
+stdlib__gc.cmo : stdlib__sys.cmi stdlib__string.cmi stdlib__printf.cmi stdlib__gc.cmi
+stdlib__gc.p.cmx : stdlib__sys.cmx stdlib__string.cmx stdlib__printf.cmx stdlib__gc.cmi
+stdlib__genlex.cmo : stdlib__string.cmi stdlib__stream.cmi stdlib__list.cmi stdlib__hashtbl.cmi stdlib__char.cmi stdlib__bytes.cmi \
+ stdlib__genlex.cmi
+stdlib__genlex.p.cmx : stdlib__string.cmx stdlib__stream.cmx stdlib__list.cmx stdlib__hashtbl.cmx stdlib__char.cmx stdlib__bytes.cmx \
+ stdlib__genlex.cmi
+stdlib__hashtbl.cmo : stdlib__sys.cmi stdlib__string.cmi stdlib__seq.cmi stdlib__random.cmi stdlib__obj.cmi stdlib__lazy.cmi \
+ stdlib__array.cmi stdlib__hashtbl.cmi
+stdlib__hashtbl.p.cmx : stdlib__sys.cmx stdlib__string.cmx stdlib__seq.cmx stdlib__random.cmx stdlib__obj.cmx stdlib__lazy.cmx \
+ stdlib__array.cmx stdlib__hashtbl.cmi
+stdlib__int32.cmo : stdlib__int32.cmi
+stdlib__int32.p.cmx : stdlib__int32.cmi
+stdlib__int64.cmo : stdlib__int64.cmi
+stdlib__int64.p.cmx : stdlib__int64.cmi
+stdlib__lazy.cmo : stdlib__obj.cmi camlinternalLazy.cmi stdlib__lazy.cmi
+stdlib__lazy.p.cmx : stdlib__obj.cmx camlinternalLazy.cmx stdlib__lazy.cmi
+stdlib__lexing.cmo : stdlib__sys.cmi stdlib__string.cmi stdlib__bytes.cmi stdlib__array.cmi stdlib__lexing.cmi
+stdlib__lexing.p.cmx : stdlib__sys.cmx stdlib__string.cmx stdlib__bytes.cmx stdlib__array.cmx stdlib__lexing.cmi
+stdlib__list.cmo : stdlib__sys.cmi stdlib__seq.cmi stdlib__list.cmi
+stdlib__list.p.cmx : stdlib__sys.cmx stdlib__seq.cmx stdlib__list.cmi
+stdlib__listLabels.cmo : stdlib__list.cmi stdlib__listLabels.cmi
+stdlib__listLabels.p.cmx : stdlib__list.cmx stdlib__listLabels.cmi
+stdlib__map.cmo : stdlib__seq.cmi stdlib__map.cmi
+stdlib__map.p.cmx : stdlib__seq.cmx stdlib__map.cmi
+stdlib__marshal.cmo : stdlib__bytes.cmi stdlib__marshal.cmi
+stdlib__marshal.p.cmx : stdlib__bytes.cmx stdlib__marshal.cmi
+stdlib__moreLabels.cmo : stdlib__set.cmi stdlib__map.cmi stdlib__hashtbl.cmi stdlib__moreLabels.cmi
+stdlib__moreLabels.p.cmx : stdlib__set.cmx stdlib__map.cmx stdlib__hashtbl.cmx stdlib__moreLabels.cmi
+stdlib__nativeint.cmo : stdlib__sys.cmi stdlib__nativeint.cmi
+stdlib__nativeint.p.cmx : stdlib__sys.cmx stdlib__nativeint.cmi
+stdlib__obj.cmo : stdlib__marshal.cmi stdlib__int32.cmi stdlib__obj.cmi
+stdlib__obj.p.cmx : stdlib__marshal.cmx stdlib__int32.cmx stdlib__obj.cmi
+stdlib__oo.cmo : camlinternalOO.cmi stdlib__oo.cmi
+stdlib__oo.p.cmx : camlinternalOO.cmx stdlib__oo.cmi
+stdlib__parsing.cmo : stdlib__obj.cmi stdlib__lexing.cmi stdlib__array.cmi stdlib__parsing.cmi
+stdlib__parsing.p.cmx : stdlib__obj.cmx stdlib__lexing.cmx stdlib__array.cmx stdlib__parsing.cmi
+stdlib__printexc.cmo : stdlib__printf.cmi stdlib__obj.cmi stdlib__buffer.cmi stdlib__array.cmi stdlib__printexc.cmi
+stdlib__printexc.p.cmx : stdlib__printf.cmx stdlib__obj.cmx stdlib__buffer.cmx stdlib__array.cmx stdlib__printexc.cmi
+stdlib__printf.cmo : camlinternalFormatBasics.cmi camlinternalFormat.cmi stdlib__buffer.cmi \
+ stdlib__printf.cmi
+stdlib__printf.p.cmx : camlinternalFormatBasics.cmx camlinternalFormat.cmx stdlib__buffer.cmx \
+ stdlib__printf.cmi
+stdlib__queue.cmo : stdlib__seq.cmi stdlib__queue.cmi
+stdlib__queue.p.cmx : stdlib__seq.cmx stdlib__queue.cmi
+stdlib__random.cmo : stdlib__string.cmi stdlib__nativeint.cmi stdlib__int64.cmi stdlib__int32.cmi stdlib__digest.cmi \
+ stdlib__char.cmi stdlib__array.cmi stdlib__random.cmi
+stdlib__random.p.cmx : stdlib__string.cmx stdlib__nativeint.cmx stdlib__int64.cmx stdlib__int32.cmx stdlib__digest.cmx \
+ stdlib__char.cmx stdlib__array.cmx stdlib__random.cmi
+stdlib__scanf.cmo : stdlib__string.cmi stdlib__printf.cmi stdlib__list.cmi camlinternalFormatBasics.cmi \
+ camlinternalFormat.cmi stdlib__bytes.cmi stdlib__buffer.cmi stdlib__scanf.cmi
+stdlib__scanf.p.cmx : stdlib__string.cmx stdlib__printf.cmx stdlib__list.cmx camlinternalFormatBasics.cmx \
+ camlinternalFormat.cmx stdlib__bytes.cmx stdlib__buffer.cmx stdlib__scanf.cmi
+stdlib__seq.cmo : stdlib__seq.cmi
+stdlib__seq.p.cmx : stdlib__seq.cmi
+stdlib__set.cmo : stdlib__seq.cmi stdlib__list.cmi stdlib__set.cmi
+stdlib__set.p.cmx : stdlib__seq.cmx stdlib__list.cmx stdlib__set.cmi
+stdlib__sort.cmo : stdlib__array.cmi stdlib__sort.cmi
+stdlib__sort.p.cmx : stdlib__array.cmx stdlib__sort.cmi
+stdlib__spacetime.cmo : stdlib__gc.cmi stdlib__spacetime.cmi
+stdlib__spacetime.p.cmx : stdlib__gc.cmx stdlib__spacetime.cmi
+stdlib__stack.cmo : stdlib__seq.cmi stdlib__list.cmi stdlib__stack.cmi
+stdlib__stack.p.cmx : stdlib__seq.cmx stdlib__list.cmx stdlib__stack.cmi
+stdlib__stdLabels.cmo : stdlib__stringLabels.cmi stdlib__listLabels.cmi stdlib__bytesLabels.cmi \
+ stdlib__arrayLabels.cmi stdlib__stdLabels.cmi
+stdlib__stdLabels.p.cmx : stdlib__stringLabels.cmx stdlib__listLabels.cmx stdlib__bytesLabels.cmx \
+ stdlib__arrayLabels.cmx stdlib__stdLabels.cmi
std_exit.cmo :
std_exit.cmx :
-stream.cmo : string.cmi list.cmi lazy.cmi bytes.cmi stream.cmi
-stream.p.cmx : string.cmx list.cmx lazy.cmx bytes.cmx stream.cmi
-string.cmo : pervasives.cmi bytes.cmi string.cmi
-string.p.cmx : pervasives.cmx bytes.cmx string.cmi
-stringLabels.cmo : string.cmi stringLabels.cmi
-stringLabels.p.cmx : string.cmx stringLabels.cmi
-sys.cmo : sys.cmi
-sys.p.cmx : sys.cmi
-uchar.cmo : pervasives.cmi char.cmi uchar.cmi
-uchar.p.cmx : pervasives.cmx char.cmx uchar.cmi
-weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
-weak.p.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi
+stdlib__stream.cmo : stdlib__string.cmi stdlib__list.cmi stdlib__lazy.cmi stdlib__bytes.cmi stdlib__stream.cmi
+stdlib__stream.p.cmx : stdlib__string.cmx stdlib__list.cmx stdlib__lazy.cmx stdlib__bytes.cmx stdlib__stream.cmi
+stdlib__string.cmo : stdlib__bytes.cmi stdlib__string.cmi
+stdlib__string.p.cmx : stdlib__bytes.cmx stdlib__string.cmi
+stdlib__stringLabels.cmo : stdlib__string.cmi stdlib__stringLabels.cmi
+stdlib__stringLabels.p.cmx : stdlib__string.cmx stdlib__stringLabels.cmi
+stdlib__sys.cmo : stdlib__sys.cmi
+stdlib__sys.p.cmx : stdlib__sys.cmi
+stdlib__uchar.cmo : stdlib__char.cmi stdlib__uchar.cmi
+stdlib__uchar.p.cmx : stdlib__char.cmx stdlib__uchar.cmi
+stdlib__weak.cmo : stdlib__sys.cmi stdlib__obj.cmi stdlib__hashtbl.cmi stdlib__array.cmi stdlib__weak.cmi
+stdlib__weak.p.cmx : stdlib__sys.cmx stdlib__obj.cmx stdlib__hashtbl.cmx stdlib__array.cmx stdlib__weak.cmi
+stdlib.cmo : camlinternalFormatBasics.cmi stdlib.cmi
+stdlib.p.cmx : camlinternalFormatBasics.cmx stdlib.cmi
#**************************************************************************
case $1 in
- pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives';;
- camlinternalOO.cmi) echo ' -nopervasives';;
+ stdlib.cm[iox]|stdlib.p.cmx)
+ echo ' -nopervasives -no-alias-deps -w -49' \
+ ' -pp "$AWK -f expand_module_aliases.awk"';;
+ stdlib__pervasives.cm[iox]|stdlib__pervasives.p.cmx) echo ' -nopervasives';;
camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';;
- buffer.cmx|buffer.p.cmx) echo ' -inline 3';;
+ stdlib__buffer.cmx|stdlib__buffer.p.cmx) echo ' -inline 3';;
# make sure add_char is inlined (PR#5872)
- buffer.cm[io]) echo ' -w A';;
+ stdlib__buffer.cm[io]) echo ' -w A';;
camlinternalFormat.cm[io]) echo ' -w Ae';;
camlinternalFormatBasics*.cm[iox]) echo ' -nopervasives';;
- printf.cm[io]|format.cm[io]|scanf.cm[io]) echo ' -w Ae';;
- scanf.cmx|scanf.p.cmx) echo ' -inline 9';;
+ stdlib__printf.cm[io]|stdlib__format.cm[io]|stdlib__scanf.cm[io])
+ echo ' -w Ae';;
+ stdlib__scanf.cmx|stdlib__scanf.p.cmx) echo ' -inline 9';;
*Labels.cm[ox]|*Labels.p.cmx) echo ' -nolabels -no-alias-deps';;
+ pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives -no-alias-deps -w -49';;
*) echo ' ';;
esac
#**************************************************************************
include ../config/Makefile
+include ../Makefile.common
+
CAMLRUN ?= ../boot/ocamlrun
CAMLYACC ?= ../boot/ocamlyacc
TARGET_BINDIR ?= $(BINDIR)
CAMLOPT=$(CAMLRUN) $(OPTCOMPILER)
CAMLDEP=$(CAMLRUN) ../tools/ocamldep
-OBJS=camlinternalFormatBasics.cmo pervasives.cmo $(OTHERS)
-OTHERS=list.cmo char.cmo uchar.cmo bytes.cmo string.cmo sys.cmo \
- sort.cmo marshal.cmo obj.cmo array.cmo \
- int32.cmo int64.cmo nativeint.cmo \
- lexing.cmo parsing.cmo \
- set.cmo map.cmo stack.cmo queue.cmo \
- camlinternalLazy.cmo lazy.cmo stream.cmo \
- buffer.cmo camlinternalFormat.cmo printf.cmo \
- arg.cmo printexc.cmo gc.cmo \
- digest.cmo random.cmo hashtbl.cmo weak.cmo \
- format.cmo scanf.cmo callback.cmo \
- camlinternalOO.cmo oo.cmo camlinternalMod.cmo \
- genlex.cmo ephemeron.cmo \
- filename.cmo complex.cmo \
- arrayLabels.cmo listLabels.cmo bytesLabels.cmo \
- stringLabels.cmo moreLabels.cmo stdLabels.cmo \
- spacetime.cmo camlinternalBigarray.cmo
+# Object file prefix
+P=stdlib__
+
+OBJS=camlinternalFormatBasics.cmo stdlib.cmo $(OTHERS)
+OTHERS=$(P)seq.cmo $(P)char.cmo $(P)uchar.cmo $(P)sys.cmo $(P)list.cmo \
+ $(P)bytes.cmo $(P)string.cmo \
+ $(P)sort.cmo $(P)marshal.cmo $(P)obj.cmo $(P)float.cmo $(P)array.cmo \
+ $(P)int32.cmo $(P)int64.cmo $(P)nativeint.cmo \
+ $(P)lexing.cmo $(P)parsing.cmo \
+ $(P)set.cmo $(P)map.cmo $(P)stack.cmo $(P)queue.cmo \
+ camlinternalLazy.cmo $(P)lazy.cmo $(P)stream.cmo \
+ $(P)buffer.cmo camlinternalFormat.cmo $(P)printf.cmo \
+ $(P)arg.cmo $(P)printexc.cmo $(P)gc.cmo \
+ $(P)digest.cmo $(P)random.cmo $(P)hashtbl.cmo $(P)weak.cmo \
+ $(P)format.cmo $(P)scanf.cmo $(P)callback.cmo \
+ camlinternalOO.cmo $(P)oo.cmo camlinternalMod.cmo \
+ $(P)genlex.cmo $(P)ephemeron.cmo \
+ $(P)filename.cmo $(P)complex.cmo \
+ $(P)arrayLabels.cmo $(P)listLabels.cmo $(P)bytesLabels.cmo \
+ $(P)stringLabels.cmo $(P)moreLabels.cmo $(P)stdLabels.cmo \
+ $(P)spacetime.cmo $(P)bigarray.cmo
+
+PREFIXED_OBJS=$(filter stdlib__%.cmo,$(OBJS))
.PHONY: all
all: stdlib.cma std_exit.cmo camlheader target_camlheader camlheader_ur
ifeq "$(RUNTIMED)" "true"
-all: camlheaderd
+all: camlheaderd target_camlheaderd
endif
ifeq "$(RUNTIMEI)" "true"
-all: camlheaderi
+all: camlheaderi target_camlheaderi
endif
ifeq "$(PROFILING)" "true"
allopt-prof: stdlib.p.cmxa std_exit.p.cmx
rm -f std_exit.p.cmi
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-
.PHONY: install
install::
- cp stdlib.cma std_exit.cmo *.cmi *.cmt *.cmti *.mli *.ml \
- camlheader_ur \
+# Transitional: when upgrading from 4.06 -> 4.07, module M is in stdlib__m.cm*,
+# while previously it was in m.cm*, which confuses the compiler.
+ rm -f $(patsubst stdlib__%,"$(INSTALL_LIBDIR)/%", $(filter stdlib__%,$(OBJS)))
+# Remove "old" pervasives.* and bigarray.* to avoid getting confused with the
+# Stdlib versions.
+ rm -f "$(INSTALL_LIBDIR)/pervasives.*" "$(INSTALL_LIBDIR)/bigarray.*"
+# End transitional
+ $(INSTALL_DATA) \
+ stdlib.cma std_exit.cmo *.cmi *.cmt *.cmti *.mli *.ml camlheader_ur \
"$(INSTALL_LIBDIR)"
- cp target_camlheader "$(INSTALL_LIBDIR)/camlheader"
+ $(INSTALL_DATA) target_camlheader "$(INSTALL_LIBDIR)/camlheader"
ifeq "$(RUNTIMED)" "true"
install::
- cp target_camlheaderd $(INSTALL_LIBDIR)
+ $(INSTALL_DATA) target_camlheaderd $(INSTALL_LIBDIR)
endif
ifeq "$(RUNTIMEI)" "true"
install::
- cp target_camlheaderi $(INSTALL_LIBDIR)
+ $(INSTALL_DATA) target_camlheaderi $(INSTALL_LIBDIR)
endif
.PHONY: installopt
.PHONY: installopt-default
installopt-default:
- cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx "$(INSTALL_LIBDIR)"
+ $(INSTALL_DATA) \
+ stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx \
+ "$(INSTALL_LIBDIR)"
cd "$(INSTALL_LIBDIR)"; $(RANLIB) stdlib.$(A)
.PHONY: installopt-noprof
.PHONY: installopt-prof
installopt-prof:
- cp stdlib.p.cmxa stdlib.p.$(A) std_exit.p.cmx std_exit.p.$(O) \
+ $(INSTALL_DATA) \
+ stdlib.p.cmxa stdlib.p.$(A) std_exit.p.cmx std_exit.p.$(O) \
"$(INSTALL_LIBDIR)"
cd "$(INSTALL_LIBDIR)"; $(RANLIB) stdlib.p.$(A)
# TODO: see whether there is a way to further merge the rules below
# with those above
-camlheader target_camlheader camlheader_ur: headernt.c
+camlheader: headernt.c
$(CC) -c $(CFLAGS) $(CPPFLAGS) -I../byterun \
-DRUNTIME_NAME='"ocamlrun"' $(OUTPUTOBJ)headernt.$(O) $<
$(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
rm -f camlheader.exe
mv tmpheader.exe camlheader
+
+target_camlheader: camlheader
cp camlheader target_camlheader
+
+camlheader_ur: camlheader
cp camlheader camlheader_ur
-camlheaderd target_camlheaderd: headernt.c
+camlheaderd: headernt.c
$(CC) -c $(CFLAGS) $(CPPFLAGS) -I../byterun \
- -DRUNTIME_NAME='"ocamlrund"' $(OUTPUTOBJ)headernt.$(O) $<
- $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
- mv tmpheader.exe camlheaderd
+ -DRUNTIME_NAME='"ocamlrund"' $(OUTPUTOBJ)headerntd.$(O) $<
+ $(MKEXE) -o tmpheaderd.exe headerntd.$(O) $(EXTRALIBS)
+ mv tmpheaderd.exe camlheaderd
+
+target_camlheaderd: camlheaderd
cp camlheaderd target_camlheaderd
camlheaderi: headernt.c
$(CC) -c $(CFLAGS) $(CPPFLAGS) -I../byterun \
- -DRUNTIME_NAME='"ocamlruni"' $(OUTPUTOBJ)headernt.$(O)
- $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
- mv tmpheader.exe camlheaderi
+ -DRUNTIME_NAME='"ocamlruni"' $(OUTPUTOBJ)headernti.$(O) $<
+ $(MKEXE) -o tmpheaderi.exe headernti.$(O) $(EXTRALIBS)
+ mv tmpheaderi.exe camlheaderi
+
+target_camlheaderi: camlheaderi
+ cp camlheaderi target_camlheaderi
# TODO: do not call flexlink to build tmpheader.exe (we don't need
# the export table)
.SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx
-.mli.cmi:
- $(CAMLC) $(COMPFLAGS) `sh ./Compflags $@` -c $<
+export AWK
+
+%.cmi: %.mli
+ $(CAMLC) $(COMPFLAGS) $(shell ./Compflags $@) -c $<
+
+stdlib__%.cmi: %.mli
+ $(CAMLC) $(COMPFLAGS) $(shell ./Compflags $@) -o $@ -c $<
+
+%.cmo: %.ml
+ $(CAMLC) $(COMPFLAGS) $(shell ./Compflags $@) -c $<
-.ml.cmo:
- $(CAMLC) $(COMPFLAGS) `sh ./Compflags $@` -c $<
+stdlib__%.cmo: %.ml
+ $(CAMLC) $(COMPFLAGS) $(shell ./Compflags $@) -o $@ -c $<
-.ml.cmx:
- $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) `sh ./Compflags $@` -c $<
+%.cmx: %.ml
+ $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) $(shell ./Compflags $@) -c $<
-.ml.p.cmx:
- $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) `sh ./Compflags $@` \
- -p -c -o $*.p.cmx $<
+stdlib__%.cmx: %.ml
+ $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) $(shell ./Compflags $@) \
+ -o $@ -c $<
+
+%.p.cmx: %.ml
+ $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) $(shell ./Compflags $@) \
+ -p -c -o $@ $<
+
+stdlib__%.p.cmx: %.ml
+ $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) $(shell ./Compflags $@) \
+ -p -c -o $@ $<
# Dependencies on the compiler
COMPILER_DEPS=$(filter-out -use-prims, $(COMPILER))
$(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER)
$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER)
-# Dependencies on Pervasives (not tracked by ocamldep)
-$(OTHERS) std_exit.cmo: pervasives.cmi
-$(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi
-$(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi
-$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi
-$(OTHERS:.cmo=.cmx) std_exit.cmx: pervasives.cmx
-$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmx
+# Dependencies on Stdlib (not tracked by ocamldep)
+$(OTHERS) std_exit.cmo: stdlib.cmi
+$(OTHERS:.cmo=.cmi) std_exit.cmi: stdlib.cmi
+$(OBJS:.cmo=.cmx) std_exit.cmx: stdlib.cmi
+$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: stdlib.cmi
+$(OTHERS:.cmo=.cmx) std_exit.cmx: stdlib.cmx
+$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: stdlib.cmx
clean::
- rm -f *.cm* *.$(O) *.$(A)
+ rm -f *.cm* *.$(O) *.$(A) *.odoc
rm -f *~
rm -f camlheader*
include .depend
+EMPTY :=
+SPACE := $(EMPTY) $(EMPTY)
+
# Note that .p.cmx targets do not depend (for compilation) upon other
# .p.cmx files. When the compiler imports another compilation unit,
# it looks for the .cmx file (not .p.cmx).
.PHONY: depend
depend:
- $(CAMLDEP) -slash *.mli *.ml > .depend
- $(CAMLDEP) -slash *.ml | sed -e 's/\.cmx : /.p.cmx : /g' >>.depend
+ $(CAMLDEP) -slash $(filter-out stdlib.%,$(wildcard *.mli *.ml)) \
+ > .depend.tmp
+ $(CAMLDEP) -slash -pp "$(AWK) -f remove_module_aliases.awk" \
+ stdlib.ml stdlib.mli >> .depend.tmp
+ $(CAMLDEP) -slash $(filter-out stdlib.%,$(wildcard *.ml)) \
+ | sed -e 's/\.cmx : /.p.cmx : /g' >>.depend.tmp
+ $(CAMLDEP) -slash -pp "$(AWK) -f remove_module_aliases.awk" stdlib.ml \
+ | sed -e 's/\.cmx : /.p.cmx : /g' >> .depend.tmp
+ sed -Ee \
+ 's#(^| )(${subst ${SPACE},|,${PREFIXED_OBJS:stdlib__%.cmo=%}})[.]#\1stdlib__\2.#g' \
+ .depend.tmp > .depend
+ rm -f .depend.tmp
# This file lists all standard library modules.
# It is used in particular to know what to expunge in toplevels.
+P ?= stdlib__
+
STDLIB_MODULES=\
- spacetime \
- arg \
- array \
- arrayLabels \
- buffer \
- bytes \
- bytesLabels \
- callback \
+ $(P)spacetime \
+ $(P)arg \
+ $(P)array \
+ $(P)arrayLabels \
+ $(P)bigarray \
+ $(P)buffer \
+ $(P)bytes \
+ $(P)bytesLabels \
+ $(P)callback \
camlinternalFormat \
camlinternalFormatBasics \
camlinternalLazy \
camlinternalMod \
camlinternalOO \
- char \
- complex \
- digest \
- ephemeron \
- filename \
- format \
- gc \
- genlex \
- hashtbl \
- int32 \
- int64 \
- lazy \
- lexing \
- list \
- listLabels \
- map \
- marshal \
- moreLabels \
- nativeint \
- obj \
- oo \
- parsing \
- pervasives \
- printexc \
- printf \
- queue \
- random \
- scanf \
- set \
- sort \
- stack \
- stdLabels \
- stream \
- string \
- stringLabels \
- sys \
- uchar \
- weak
+ $(P)char \
+ $(P)complex \
+ $(P)digest \
+ $(P)ephemeron \
+ $(P)filename \
+ $(P)float \
+ $(P)format \
+ $(P)gc \
+ $(P)genlex \
+ $(P)hashtbl \
+ $(P)int32 \
+ $(P)int64 \
+ $(P)lazy \
+ $(P)lexing \
+ $(P)list \
+ $(P)listLabels \
+ $(P)map \
+ $(P)marshal \
+ $(P)moreLabels \
+ $(P)nativeint \
+ $(P)obj \
+ $(P)oo \
+ $(P)parsing \
+ $(P)printexc \
+ $(P)printf \
+ $(P)queue \
+ $(P)random \
+ $(P)scanf \
+ $(P)seq \
+ $(P)set \
+ $(P)sort \
+ $(P)stack \
+ $(P)stdLabels \
+ stdlib \
+ $(P)stream \
+ $(P)string \
+ $(P)stringLabels \
+ $(P)sys \
+ $(P)uchar \
+ $(P)weak
let buf = Buffer.create 200 in
let words = ref [] in
let stash () =
- let word = (Buffer.contents buf) in
+ let word = Buffer.contents buf in
let word = if trim then trim_cr word else word in
words := word :: !words;
Buffer.clear buf
in
- let rec read () =
- try
- let c = input_char ic in
- if c = sep then begin
- stash (); read ()
- end else begin
- Buffer.add_char buf c; read ()
- end
- with End_of_file ->
- if Buffer.length buf > 0 then
- stash () in
- read ();
+ begin
+ try while true do
+ let c = input_char ic in
+ if c = sep then stash () else Buffer.add_char buf c
+ done
+ with End_of_file -> ()
+ end;
+ if Buffer.length buf > 0 then stash ();
close_in ic;
Array.of_list (List.rev !words)
let fast_sort = stable_sort
+
+(** {6 Iterators} *)
+
+let to_seq a =
+ let rec aux i () =
+ if i < length a
+ then
+ let x = unsafe_get a i in
+ Seq.Cons (x, aux (i+1))
+ else Seq.Nil
+ in
+ aux 0
+
+let to_seqi a =
+ let rec aux i () =
+ if i < length a
+ then
+ let x = unsafe_get a i in
+ Seq.Cons ((i,x), aux (i+1))
+ else Seq.Nil
+ in
+ aux 0
+
+let of_rev_list = function
+ [] -> [||]
+ | hd::tl as l ->
+ let len = list_length 0 l in
+ let a = create len hd in
+ let rec fill i = function
+ [] -> a
+ | hd::tl -> unsafe_set a i hd; fill (i-1) tl
+ in
+ fill (len-1) tl
+
+let of_seq i =
+ let l = Seq.fold_left (fun acc x -> x::acc) [] i in
+ of_rev_list l
*)
+(** {6 Iterators} *)
+
+val to_seq : 'a array -> 'a Seq.t
+(** Iterate on the array, in increasing order. Modifications of the
+ array during iteration will be reflected in the iterator.
+ @since 4.07 *)
+
+val to_seqi : 'a array -> (int * 'a) Seq.t
+(** Iterate on the array, in increasing order, yielding indices along elements.
+ Modifications of the array during iteration will be reflected in the
+ iterator.
+ @since 4.07 *)
+
+val of_seq : 'a Seq.t -> 'a array
+(** Create an array from the generator
+ @since 4.07 *)
+
(**/**)
(** {1 Undocumented functions} *)
*)
+(** {6 Iterators} *)
+
+val to_seq : 'a array -> 'a Seq.t
+(** Iterate on the array, in increasing order
+ @since 4.07 *)
+
+val to_seqi : 'a array -> (int * 'a) Seq.t
+(** Iterate on the array, in increasing order, yielding indices along elements
+ @since 4.07 *)
+
+val of_seq : 'a Seq.t -> 'a array
+(** Create an array from the generator
+ @since 4.07 *)
+
(**/**)
(** {1 Undocumented functions} *)
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Manuel Serrano et Xavier Leroy, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2000 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Module [Bigarray]: large, multi-dimensional, numerical arrays *)
+
+(* These types in must be kept in sync with the tables in
+ ../typing/typeopt.ml *)
+
+type float32_elt = Float32_elt
+type float64_elt = Float64_elt
+type int8_signed_elt = Int8_signed_elt
+type int8_unsigned_elt = Int8_unsigned_elt
+type int16_signed_elt = Int16_signed_elt
+type int16_unsigned_elt = Int16_unsigned_elt
+type int32_elt = Int32_elt
+type int64_elt = Int64_elt
+type int_elt = Int_elt
+type nativeint_elt = Nativeint_elt
+type complex32_elt = Complex32_elt
+type complex64_elt = Complex64_elt
+
+type ('a, 'b) kind =
+ Float32 : (float, float32_elt) kind
+ | Float64 : (float, float64_elt) kind
+ | Int8_signed : (int, int8_signed_elt) kind
+ | Int8_unsigned : (int, int8_unsigned_elt) kind
+ | Int16_signed : (int, int16_signed_elt) kind
+ | Int16_unsigned : (int, int16_unsigned_elt) kind
+ | Int32 : (int32, int32_elt) kind
+ | Int64 : (int64, int64_elt) kind
+ | Int : (int, int_elt) kind
+ | Nativeint : (nativeint, nativeint_elt) kind
+ | Complex32 : (Complex.t, complex32_elt) kind
+ | Complex64 : (Complex.t, complex64_elt) kind
+ | Char : (char, int8_unsigned_elt) kind
+
+type c_layout = C_layout_typ
+type fortran_layout = Fortran_layout_typ (**)
+
+type 'a layout =
+ C_layout: c_layout layout
+ | Fortran_layout: fortran_layout layout
+
+(* Keep those constants in sync with the caml_ba_kind enumeration
+ in bigarray.h *)
+
+let float32 = Float32
+let float64 = Float64
+let int8_signed = Int8_signed
+let int8_unsigned = Int8_unsigned
+let int16_signed = Int16_signed
+let int16_unsigned = Int16_unsigned
+let int32 = Int32
+let int64 = Int64
+let int = Int
+let nativeint = Nativeint
+let complex32 = Complex32
+let complex64 = Complex64
+let char = Char
+
+let kind_size_in_bytes : type a b. (a, b) kind -> int = function
+ | Float32 -> 4
+ | Float64 -> 8
+ | Int8_signed -> 1
+ | Int8_unsigned -> 1
+ | Int16_signed -> 2
+ | Int16_unsigned -> 2
+ | Int32 -> 4
+ | Int64 -> 8
+ | Int -> Sys.word_size / 8
+ | Nativeint -> Sys.word_size / 8
+ | Complex32 -> 8
+ | Complex64 -> 16
+ | Char -> 1
+
+(* Keep those constants in sync with the caml_ba_layout enumeration
+ in bigarray.h *)
+
+let c_layout = C_layout
+let fortran_layout = Fortran_layout
+
+module Genarray = struct
+ type ('a, 'b, 'c) t
+ external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t
+ = "caml_ba_create"
+ external get: ('a, 'b, 'c) t -> int array -> 'a
+ = "caml_ba_get_generic"
+ external set: ('a, 'b, 'c) t -> int array -> 'a -> unit
+ = "caml_ba_set_generic"
+ external num_dims: ('a, 'b, 'c) t -> int = "caml_ba_num_dims"
+ external nth_dim: ('a, 'b, 'c) t -> int -> int = "caml_ba_dim"
+ let dims a =
+ let n = num_dims a in
+ let d = Array.make n 0 in
+ for i = 0 to n-1 do d.(i) <- nth_dim a i done;
+ d
+
+ external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+ external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+ external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+ = "caml_ba_change_layout"
+
+ let size_in_bytes arr =
+ (kind_size_in_bytes (kind arr)) * (Array.fold_left ( * ) 1 (dims arr))
+
+ external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
+ = "caml_ba_sub"
+ external sub_right: ('a, 'b, fortran_layout) t -> int -> int ->
+ ('a, 'b, fortran_layout) t
+ = "caml_ba_sub"
+ external slice_left: ('a, 'b, c_layout) t -> int array ->
+ ('a, 'b, c_layout) t
+ = "caml_ba_slice"
+ external slice_right: ('a, 'b, fortran_layout) t -> int array ->
+ ('a, 'b, fortran_layout) t
+ = "caml_ba_slice"
+ external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
+ = "caml_ba_blit"
+ external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+end
+
+module Array0 = struct
+ type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
+ let create kind layout =
+ Genarray.create kind layout [||]
+ let get arr = Genarray.get arr [||]
+ let set arr = Genarray.set arr [||]
+ external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+ external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+
+ external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+ = "caml_ba_change_layout"
+
+ let size_in_bytes arr = kind_size_in_bytes (kind arr)
+
+ external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
+ external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+
+ let of_value kind layout v =
+ let a = create kind layout in
+ set a v;
+ a
+end
+
+module Array1 = struct
+ type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
+ let create kind layout dim =
+ Genarray.create kind layout [|dim|]
+ external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1"
+ external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1"
+ external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1"
+ external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit
+ = "%caml_ba_unsafe_set_1"
+ external dim: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+ external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+ external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+
+ external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+ = "caml_ba_change_layout"
+
+ let size_in_bytes arr =
+ (kind_size_in_bytes (kind arr)) * (dim arr)
+
+ external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "caml_ba_sub"
+ let slice (type t) (a : (_, _, t) Genarray.t) n =
+ match layout a with
+ | C_layout -> (Genarray.slice_left a [|n|] : (_, _, t) Genarray.t)
+ | Fortran_layout -> (Genarray.slice_right a [|n|]: (_, _, t) Genarray.t)
+ external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
+ external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+ let of_array (type t) kind (layout: t layout) data =
+ let ba = create kind layout (Array.length data) in
+ let ofs =
+ match layout with
+ C_layout -> 0
+ | Fortran_layout -> 1
+ in
+ for i = 0 to Array.length data - 1 do unsafe_set ba (i + ofs) data.(i) done;
+ ba
+end
+
+module Array2 = struct
+ type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
+ let create kind layout dim1 dim2 =
+ Genarray.create kind layout [|dim1; dim2|]
+ external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2"
+ external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2"
+ external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a
+ = "%caml_ba_unsafe_ref_2"
+ external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit
+ = "%caml_ba_unsafe_set_2"
+ external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+ external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
+ external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+ external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+
+ external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+ = "caml_ba_change_layout"
+
+ let size_in_bytes arr =
+ (kind_size_in_bytes (kind arr)) * (dim1 arr) * (dim2 arr)
+
+ external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
+ = "caml_ba_sub"
+ external sub_right:
+ ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
+ = "caml_ba_sub"
+ let slice_left a n = Genarray.slice_left a [|n|]
+ let slice_right a n = Genarray.slice_right a [|n|]
+ external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
+ external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+ let of_array (type t) kind (layout: t layout) data =
+ let dim1 = Array.length data in
+ let dim2 = if dim1 = 0 then 0 else Array.length data.(0) in
+ let ba = create kind layout dim1 dim2 in
+ let ofs =
+ match layout with
+ C_layout -> 0
+ | Fortran_layout -> 1
+ in
+ for i = 0 to dim1 - 1 do
+ let row = data.(i) in
+ if Array.length row <> dim2 then
+ invalid_arg("Bigarray.Array2.of_array: non-rectangular data");
+ for j = 0 to dim2 - 1 do
+ unsafe_set ba (i + ofs) (j + ofs) row.(j)
+ done
+ done;
+ ba
+end
+
+module Array3 = struct
+ type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
+ let create kind layout dim1 dim2 dim3 =
+ Genarray.create kind layout [|dim1; dim2; dim3|]
+ external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3"
+ external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
+ = "%caml_ba_set_3"
+ external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a
+ = "%caml_ba_unsafe_ref_3"
+ external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
+ = "%caml_ba_unsafe_set_3"
+ external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+ external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
+ external dim3: ('a, 'b, 'c) t -> int = "%caml_ba_dim_3"
+ external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+ external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+
+ external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+ = "caml_ba_change_layout"
+
+ let size_in_bytes arr =
+ (kind_size_in_bytes (kind arr)) * (dim1 arr) * (dim2 arr) * (dim3 arr)
+
+ external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
+ = "caml_ba_sub"
+ external sub_right:
+ ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
+ = "caml_ba_sub"
+ let slice_left_1 a n m = Genarray.slice_left a [|n; m|]
+ let slice_right_1 a n m = Genarray.slice_right a [|n; m|]
+ let slice_left_2 a n = Genarray.slice_left a [|n|]
+ let slice_right_2 a n = Genarray.slice_right a [|n|]
+ external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
+ external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+ let of_array (type t) kind (layout: t layout) data =
+ let dim1 = Array.length data in
+ let dim2 = if dim1 = 0 then 0 else Array.length data.(0) in
+ let dim3 = if dim2 = 0 then 0 else Array.length data.(0).(0) in
+ let ba = create kind layout dim1 dim2 dim3 in
+ let ofs =
+ match layout with
+ C_layout -> 0
+ | Fortran_layout -> 1
+ in
+ for i = 0 to dim1 - 1 do
+ let row = data.(i) in
+ if Array.length row <> dim2 then
+ invalid_arg("Bigarray.Array3.of_array: non-cubic data");
+ for j = 0 to dim2 - 1 do
+ let col = row.(j) in
+ if Array.length col <> dim3 then
+ invalid_arg("Bigarray.Array3.of_array: non-cubic data");
+ for k = 0 to dim3 - 1 do
+ unsafe_set ba (i + ofs) (j + ofs) (k + ofs) col.(k)
+ done
+ done
+ done;
+ ba
+end
+
+external genarray_of_array0: ('a, 'b, 'c) Array0.t -> ('a, 'b, 'c) Genarray.t
+ = "%identity"
+external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t
+ = "%identity"
+external genarray_of_array2: ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t
+ = "%identity"
+external genarray_of_array3: ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t
+ = "%identity"
+let array0_of_genarray a =
+ if Genarray.num_dims a = 0 then a
+ else invalid_arg "Bigarray.array0_of_genarray"
+let array1_of_genarray a =
+ if Genarray.num_dims a = 1 then a
+ else invalid_arg "Bigarray.array1_of_genarray"
+let array2_of_genarray a =
+ if Genarray.num_dims a = 2 then a
+ else invalid_arg "Bigarray.array2_of_genarray"
+let array3_of_genarray a =
+ if Genarray.num_dims a = 3 then a
+ else invalid_arg "Bigarray.array3_of_genarray"
+
+external reshape:
+ ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t
+ = "caml_ba_reshape"
+let reshape_0 a = reshape a [||]
+let reshape_1 a dim1 = reshape a [|dim1|]
+let reshape_2 a dim1 dim2 = reshape a [|dim1;dim2|]
+let reshape_3 a dim1 dim2 dim3 = reshape a [|dim1;dim2;dim3|]
+
+(* Force caml_ba_get_{1,2,3,N} to be linked in, since we don't refer
+ to those primitives directly in this file *)
+
+let _ =
+ let _ = Genarray.get in
+ let _ = Array1.get in
+ let _ = Array2.get in
+ let _ = Array3.get in
+ ()
+
+[@@@ocaml.warning "-32"]
+external get1: unit -> unit = "caml_ba_get_1"
+external get2: unit -> unit = "caml_ba_get_2"
+external get3: unit -> unit = "caml_ba_get_3"
+external set1: unit -> unit = "caml_ba_set_1"
+external set2: unit -> unit = "caml_ba_set_2"
+external set3: unit -> unit = "caml_ba_set_3"
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2000 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(** Large, multi-dimensional, numerical arrays.
+
+ This module implements multi-dimensional arrays of integers and
+ floating-point numbers, thereafter referred to as 'big arrays',
+ to distinguish them from the standard OCaml arrays described in
+ {!module:Array}.
+
+ The implementation allows efficient sharing of large numerical
+ arrays between OCaml code and C or Fortran numerical libraries.
+
+ The main differences between 'big arrays' and standard OCaml
+ arrays are as follows:
+ - Big arrays are not limited in size, unlike OCaml arrays.
+ (Normal float arrays are limited to 2,097,151 elements on a 32-bit
+ platform, and normal arrays of other types to 4,194,303 elements.)
+ - Big arrays are multi-dimensional. Any number of dimensions
+ between 0 and 16 is supported. In contrast, OCaml arrays
+ are mono-dimensional and require encoding multi-dimensional
+ arrays as arrays of arrays.
+ - Big arrays can only contain integers and floating-point numbers,
+ while OCaml arrays can contain arbitrary OCaml data types.
+ - Big arrays provide more space-efficient storage of
+ integer and floating-point elements than normal OCaml arrays, in
+ particular because they support 'small' types such as
+ single-precision floats and 8 and 16-bit integers, in addition to
+ the standard OCaml types of double-precision floats and 32 and
+ 64-bit integers.
+ - The memory layout of big arrays is entirely compatible with that
+ of arrays in C and Fortran, allowing large arrays to be passed
+ back and forth between OCaml code and C / Fortran code with no
+ data copying at all.
+ - Big arrays support interesting high-level operations that normal
+ arrays do not provide efficiently, such as extracting sub-arrays
+ and 'slicing' a multi-dimensional array along certain dimensions,
+ all without any copying.
+
+ Users of this module are encouraged to do [open Bigarray] in their
+ source, then refer to array types and operations via short dot
+ notation, e.g. [Array1.t] or [Array2.sub].
+
+ Big arrays support all the OCaml ad-hoc polymorphic operations:
+ - comparisons ([=], [<>], [<=], etc, as well as {!Pervasives.compare});
+ - hashing (module [Hash]);
+ - and structured input-output (the functions from the
+ {!Marshal} module, as well as {!Pervasives.output_value}
+ and {!Pervasives.input_value}).
+*)
+
+(** {1 Element kinds} *)
+
+(** Big arrays can contain elements of the following kinds:
+- IEEE single precision (32 bits) floating-point numbers
+ ({!Bigarray.float32_elt}),
+- IEEE double precision (64 bits) floating-point numbers
+ ({!Bigarray.float64_elt}),
+- IEEE single precision (2 * 32 bits) floating-point complex numbers
+ ({!Bigarray.complex32_elt}),
+- IEEE double precision (2 * 64 bits) floating-point complex numbers
+ ({!Bigarray.complex64_elt}),
+- 8-bit integers (signed or unsigned)
+ ({!Bigarray.int8_signed_elt} or {!Bigarray.int8_unsigned_elt}),
+- 16-bit integers (signed or unsigned)
+ ({!Bigarray.int16_signed_elt} or {!Bigarray.int16_unsigned_elt}),
+- OCaml integers (signed, 31 bits on 32-bit architectures,
+ 63 bits on 64-bit architectures) ({!Bigarray.int_elt}),
+- 32-bit signed integers ({!Bigarray.int32_elt}),
+- 64-bit signed integers ({!Bigarray.int64_elt}),
+- platform-native signed integers (32 bits on 32-bit architectures,
+ 64 bits on 64-bit architectures) ({!Bigarray.nativeint_elt}).
+
+ Each element kind is represented at the type level by one of the
+ [*_elt] types defined below (defined with a single constructor instead
+ of abstract types for technical injectivity reasons).
+
+ @since 4.07.0 Moved from otherlibs to stdlib.
+*)
+
+type float32_elt = Float32_elt
+type float64_elt = Float64_elt
+type int8_signed_elt = Int8_signed_elt
+type int8_unsigned_elt = Int8_unsigned_elt
+type int16_signed_elt = Int16_signed_elt
+type int16_unsigned_elt = Int16_unsigned_elt
+type int32_elt = Int32_elt
+type int64_elt = Int64_elt
+type int_elt = Int_elt
+type nativeint_elt = Nativeint_elt
+type complex32_elt = Complex32_elt
+type complex64_elt = Complex64_elt
+
+type ('a, 'b) kind =
+ Float32 : (float, float32_elt) kind
+ | Float64 : (float, float64_elt) kind
+ | Int8_signed : (int, int8_signed_elt) kind
+ | Int8_unsigned : (int, int8_unsigned_elt) kind
+ | Int16_signed : (int, int16_signed_elt) kind
+ | Int16_unsigned : (int, int16_unsigned_elt) kind
+ | Int32 : (int32, int32_elt) kind
+ | Int64 : (int64, int64_elt) kind
+ | Int : (int, int_elt) kind
+ | Nativeint : (nativeint, nativeint_elt) kind
+ | Complex32 : (Complex.t, complex32_elt) kind
+ | Complex64 : (Complex.t, complex64_elt) kind
+ | Char : (char, int8_unsigned_elt) kind (**)
+(** To each element kind is associated an OCaml type, which is
+ the type of OCaml values that can be stored in the big array
+ or read back from it. This type is not necessarily the same
+ as the type of the array elements proper: for instance,
+ a big array whose elements are of kind [float32_elt] contains
+ 32-bit single precision floats, but reading or writing one of
+ its elements from OCaml uses the OCaml type [float], which is
+ 64-bit double precision floats.
+
+ The GADT type [('a, 'b) kind] captures this association
+ of an OCaml type ['a] for values read or written in the big array,
+ and of an element kind ['b] which represents the actual contents
+ of the big array. Its constructors list all possible associations
+ of OCaml types with element kinds, and are re-exported below for
+ backward-compatibility reasons.
+
+ Using a generalized algebraic datatype (GADT) here allows to write
+ well-typed polymorphic functions whose return type depend on the
+ argument type, such as:
+
+{[
+ let zero : type a b. (a, b) kind -> a = function
+ | Float32 -> 0.0 | Complex32 -> Complex.zero
+ | Float64 -> 0.0 | Complex64 -> Complex.zero
+ | Int8_signed -> 0 | Int8_unsigned -> 0
+ | Int16_signed -> 0 | Int16_unsigned -> 0
+ | Int32 -> 0l | Int64 -> 0L
+ | Int -> 0 | Nativeint -> 0n
+ | Char -> '\000'
+]}
+*)
+
+val float32 : (float, float32_elt) kind
+(** See {!Bigarray.char}. *)
+
+val float64 : (float, float64_elt) kind
+(** See {!Bigarray.char}. *)
+
+val complex32 : (Complex.t, complex32_elt) kind
+(** See {!Bigarray.char}. *)
+
+val complex64 : (Complex.t, complex64_elt) kind
+(** See {!Bigarray.char}. *)
+
+val int8_signed : (int, int8_signed_elt) kind
+(** See {!Bigarray.char}. *)
+
+val int8_unsigned : (int, int8_unsigned_elt) kind
+(** See {!Bigarray.char}. *)
+
+val int16_signed : (int, int16_signed_elt) kind
+(** See {!Bigarray.char}. *)
+
+val int16_unsigned : (int, int16_unsigned_elt) kind
+(** See {!Bigarray.char}. *)
+
+val int : (int, int_elt) kind
+(** See {!Bigarray.char}. *)
+
+val int32 : (int32, int32_elt) kind
+(** See {!Bigarray.char}. *)
+
+val int64 : (int64, int64_elt) kind
+(** See {!Bigarray.char}. *)
+
+val nativeint : (nativeint, nativeint_elt) kind
+(** See {!Bigarray.char}. *)
+
+val char : (char, int8_unsigned_elt) kind
+(** As shown by the types of the values above,
+ big arrays of kind [float32_elt] and [float64_elt] are
+ accessed using the OCaml type [float]. Big arrays of complex kinds
+ [complex32_elt], [complex64_elt] are accessed with the OCaml type
+ {!Complex.t}. Big arrays of
+ integer kinds are accessed using the smallest OCaml integer
+ type large enough to represent the array elements:
+ [int] for 8- and 16-bit integer bigarrays, as well as OCaml-integer
+ bigarrays; [int32] for 32-bit integer bigarrays; [int64]
+ for 64-bit integer bigarrays; and [nativeint] for
+ platform-native integer bigarrays. Finally, big arrays of
+ kind [int8_unsigned_elt] can also be accessed as arrays of
+ characters instead of arrays of small integers, by using
+ the kind value [char] instead of [int8_unsigned]. *)
+
+val kind_size_in_bytes : ('a, 'b) kind -> int
+(** [kind_size_in_bytes k] is the number of bytes used to store
+ an element of type [k].
+
+ @since 4.03.0 *)
+
+(** {1 Array layouts} *)
+
+type c_layout = C_layout_typ (**)
+(** See {!Bigarray.fortran_layout}.*)
+
+type fortran_layout = Fortran_layout_typ (**)
+(** To facilitate interoperability with existing C and Fortran code,
+ this library supports two different memory layouts for big arrays,
+ one compatible with the C conventions,
+ the other compatible with the Fortran conventions.
+
+ In the C-style layout, array indices start at 0, and
+ multi-dimensional arrays are laid out in row-major format.
+ That is, for a two-dimensional array, all elements of
+ row 0 are contiguous in memory, followed by all elements of
+ row 1, etc. In other terms, the array elements at [(x,y)]
+ and [(x, y+1)] are adjacent in memory.
+
+ In the Fortran-style layout, array indices start at 1, and
+ multi-dimensional arrays are laid out in column-major format.
+ That is, for a two-dimensional array, all elements of
+ column 0 are contiguous in memory, followed by all elements of
+ column 1, etc. In other terms, the array elements at [(x,y)]
+ and [(x+1, y)] are adjacent in memory.
+
+ Each layout style is identified at the type level by the
+ phantom types {!Bigarray.c_layout} and {!Bigarray.fortran_layout}
+ respectively. *)
+
+(** {7 Supported layouts}
+
+ The GADT type ['a layout] represents one of the two supported
+ memory layouts: C-style or Fortran-style. Its constructors are
+ re-exported as values below for backward-compatibility reasons.
+*)
+
+type 'a layout =
+ C_layout: c_layout layout
+ | Fortran_layout: fortran_layout layout
+
+val c_layout : c_layout layout
+val fortran_layout : fortran_layout layout
+
+
+(** {1 Generic arrays (of arbitrarily many dimensions)} *)
+
+module Genarray :
+ sig
+ type ('a, 'b, 'c) t
+ (** The type [Genarray.t] is the type of big arrays with variable
+ numbers of dimensions. Any number of dimensions between 0 and 16
+ is supported.
+
+ The three type parameters to [Genarray.t] identify the array element
+ kind and layout, as follows:
+ - the first parameter, ['a], is the OCaml type for accessing array
+ elements ([float], [int], [int32], [int64], [nativeint]);
+ - the second parameter, ['b], is the actual kind of array elements
+ ([float32_elt], [float64_elt], [int8_signed_elt], [int8_unsigned_elt],
+ etc);
+ - the third parameter, ['c], identifies the array layout
+ ([c_layout] or [fortran_layout]).
+
+ For instance, [(float, float32_elt, fortran_layout) Genarray.t]
+ is the type of generic big arrays containing 32-bit floats
+ in Fortran layout; reads and writes in this array use the
+ OCaml type [float]. *)
+
+ external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t
+ = "caml_ba_create"
+ (** [Genarray.create kind layout dimensions] returns a new big array
+ whose element kind is determined by the parameter [kind] (one of
+ [float32], [float64], [int8_signed], etc) and whose layout is
+ determined by the parameter [layout] (one of [c_layout] or
+ [fortran_layout]). The [dimensions] parameter is an array of
+ integers that indicate the size of the big array in each dimension.
+ The length of [dimensions] determines the number of dimensions
+ of the bigarray.
+
+ For instance, [Genarray.create int32 c_layout [|4;6;8|]]
+ returns a fresh big array of 32-bit integers, in C layout,
+ having three dimensions, the three dimensions being 4, 6 and 8
+ respectively.
+
+ Big arrays returned by [Genarray.create] are not initialized:
+ the initial values of array elements is unspecified.
+
+ [Genarray.create] raises [Invalid_argument] if the number of dimensions
+ is not in the range 0 to 16 inclusive, or if one of the dimensions
+ is negative. *)
+
+ external num_dims: ('a, 'b, 'c) t -> int = "caml_ba_num_dims"
+ (** Return the number of dimensions of the given big array. *)
+
+ val dims : ('a, 'b, 'c) t -> int array
+ (** [Genarray.dims a] returns all dimensions of the big array [a],
+ as an array of integers of length [Genarray.num_dims a]. *)
+
+ external nth_dim: ('a, 'b, 'c) t -> int -> int = "caml_ba_dim"
+ (** [Genarray.nth_dim a n] returns the [n]-th dimension of the
+ big array [a]. The first dimension corresponds to [n = 0];
+ the second dimension corresponds to [n = 1]; the last dimension,
+ to [n = Genarray.num_dims a - 1].
+ Raise [Invalid_argument] if [n] is less than 0 or greater or equal than
+ [Genarray.num_dims a]. *)
+
+ external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+ (** Return the kind of the given big array. *)
+
+ external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+ (** Return the layout of the given big array. *)
+
+ external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+ = "caml_ba_change_layout"
+ (** [Genarray.change_layout a layout] returns a bigarray with the
+ specified [layout], sharing the data with [a] (and hence having
+ the same dimensions as [a]). No copying of elements is involved: the
+ new array and the original array share the same storage space.
+ The dimensions are reversed, such that [get v [| a; b |]] in
+ C layout becomes [get v [| b+1; a+1 |]] in Fortran layout.
+
+ @since 4.04.0
+ *)
+
+ val size_in_bytes : ('a, 'b, 'c) t -> int
+ (** [size_in_bytes a] is the number of elements in [a] multiplied
+ by [a]'s {!kind_size_in_bytes}.
+
+ @since 4.03.0 *)
+
+ external get: ('a, 'b, 'c) t -> int array -> 'a = "caml_ba_get_generic"
+ (** Read an element of a generic big array.
+ [Genarray.get a [|i1; ...; iN|]] returns the element of [a]
+ whose coordinates are [i1] in the first dimension, [i2] in
+ the second dimension, ..., [iN] in the [N]-th dimension.
+
+ If [a] has C layout, the coordinates must be greater or equal than 0
+ and strictly less than the corresponding dimensions of [a].
+ If [a] has Fortran layout, the coordinates must be greater or equal
+ than 1 and less or equal than the corresponding dimensions of [a].
+ Raise [Invalid_argument] if the array [a] does not have exactly [N]
+ dimensions, or if the coordinates are outside the array bounds.
+
+ If [N > 3], alternate syntax is provided: you can write
+ [a.{i1, i2, ..., iN}] instead of [Genarray.get a [|i1; ...; iN|]].
+ (The syntax [a.{...}] with one, two or three coordinates is
+ reserved for accessing one-, two- and three-dimensional arrays
+ as described below.) *)
+
+ external set: ('a, 'b, 'c) t -> int array -> 'a -> unit
+ = "caml_ba_set_generic"
+ (** Assign an element of a generic big array.
+ [Genarray.set a [|i1; ...; iN|] v] stores the value [v] in the
+ element of [a] whose coordinates are [i1] in the first dimension,
+ [i2] in the second dimension, ..., [iN] in the [N]-th dimension.
+
+ The array [a] must have exactly [N] dimensions, and all coordinates
+ must lie inside the array bounds, as described for [Genarray.get];
+ otherwise, [Invalid_argument] is raised.
+
+ If [N > 3], alternate syntax is provided: you can write
+ [a.{i1, i2, ..., iN} <- v] instead of
+ [Genarray.set a [|i1; ...; iN|] v].
+ (The syntax [a.{...} <- v] with one, two or three coordinates is
+ reserved for updating one-, two- and three-dimensional arrays
+ as described below.) *)
+
+ external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
+ = "caml_ba_sub"
+ (** Extract a sub-array of the given big array by restricting the
+ first (left-most) dimension. [Genarray.sub_left a ofs len]
+ returns a big array with the same number of dimensions as [a],
+ and the same dimensions as [a], except the first dimension,
+ which corresponds to the interval [[ofs ... ofs + len - 1]]
+ of the first dimension of [a]. No copying of elements is
+ involved: the sub-array and the original array share the same
+ storage space. In other terms, the element at coordinates
+ [[|i1; ...; iN|]] of the sub-array is identical to the
+ element at coordinates [[|i1+ofs; ...; iN|]] of the original
+ array [a].
+
+ [Genarray.sub_left] applies only to big arrays in C layout.
+ Raise [Invalid_argument] if [ofs] and [len] do not designate
+ a valid sub-array of [a], that is, if [ofs < 0], or [len < 0],
+ or [ofs + len > Genarray.nth_dim a 0]. *)
+
+ external sub_right:
+ ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
+ = "caml_ba_sub"
+ (** Extract a sub-array of the given big array by restricting the
+ last (right-most) dimension. [Genarray.sub_right a ofs len]
+ returns a big array with the same number of dimensions as [a],
+ and the same dimensions as [a], except the last dimension,
+ which corresponds to the interval [[ofs ... ofs + len - 1]]
+ of the last dimension of [a]. No copying of elements is
+ involved: the sub-array and the original array share the same
+ storage space. In other terms, the element at coordinates
+ [[|i1; ...; iN|]] of the sub-array is identical to the
+ element at coordinates [[|i1; ...; iN+ofs|]] of the original
+ array [a].
+
+ [Genarray.sub_right] applies only to big arrays in Fortran layout.
+ Raise [Invalid_argument] if [ofs] and [len] do not designate
+ a valid sub-array of [a], that is, if [ofs < 1], or [len < 0],
+ or [ofs + len > Genarray.nth_dim a (Genarray.num_dims a - 1)]. *)
+
+ external slice_left:
+ ('a, 'b, c_layout) t -> int array -> ('a, 'b, c_layout) t
+ = "caml_ba_slice"
+ (** Extract a sub-array of lower dimension from the given big array
+ by fixing one or several of the first (left-most) coordinates.
+ [Genarray.slice_left a [|i1; ... ; iM|]] returns the 'slice'
+ of [a] obtained by setting the first [M] coordinates to
+ [i1], ..., [iM]. If [a] has [N] dimensions, the slice has
+ dimension [N - M], and the element at coordinates
+ [[|j1; ...; j(N-M)|]] in the slice is identical to the element
+ at coordinates [[|i1; ...; iM; j1; ...; j(N-M)|]] in the original
+ array [a]. No copying of elements is involved: the slice and
+ the original array share the same storage space.
+
+ [Genarray.slice_left] applies only to big arrays in C layout.
+ Raise [Invalid_argument] if [M >= N], or if [[|i1; ... ; iM|]]
+ is outside the bounds of [a]. *)
+
+ external slice_right:
+ ('a, 'b, fortran_layout) t -> int array -> ('a, 'b, fortran_layout) t
+ = "caml_ba_slice"
+ (** Extract a sub-array of lower dimension from the given big array
+ by fixing one or several of the last (right-most) coordinates.
+ [Genarray.slice_right a [|i1; ... ; iM|]] returns the 'slice'
+ of [a] obtained by setting the last [M] coordinates to
+ [i1], ..., [iM]. If [a] has [N] dimensions, the slice has
+ dimension [N - M], and the element at coordinates
+ [[|j1; ...; j(N-M)|]] in the slice is identical to the element
+ at coordinates [[|j1; ...; j(N-M); i1; ...; iM|]] in the original
+ array [a]. No copying of elements is involved: the slice and
+ the original array share the same storage space.
+
+ [Genarray.slice_right] applies only to big arrays in Fortran layout.
+ Raise [Invalid_argument] if [M >= N], or if [[|i1; ... ; iM|]]
+ is outside the bounds of [a]. *)
+
+ external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
+ = "caml_ba_blit"
+ (** Copy all elements of a big array in another big array.
+ [Genarray.blit src dst] copies all elements of [src] into
+ [dst]. Both arrays [src] and [dst] must have the same number of
+ dimensions and equal dimensions. Copying a sub-array of [src]
+ to a sub-array of [dst] can be achieved by applying [Genarray.blit]
+ to sub-array or slices of [src] and [dst]. *)
+
+ external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+ (** Set all elements of a big array to a given value.
+ [Genarray.fill a v] stores the value [v] in all elements of
+ the big array [a]. Setting only some elements of [a] to [v]
+ can be achieved by applying [Genarray.fill] to a sub-array
+ or a slice of [a]. *)
+ end
+
+(** {1 Zero-dimensional arrays} *)
+
+(** Zero-dimensional arrays. The [Array0] structure provides operations
+ similar to those of {!Bigarray.Genarray}, but specialized to the case
+ of zero-dimensional arrays that only contain a single scalar value.
+ Statically knowing the number of dimensions of the array allows
+ faster operations, and more precise static type-checking.
+ @since 4.05.0 *)
+module Array0 : sig
+ type ('a, 'b, 'c) t
+ (** The type of zero-dimensional big arrays whose elements have
+ OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
+
+ val create: ('a, 'b) kind -> 'c layout -> ('a, 'b, 'c) t
+ (** [Array0.create kind layout] returns a new bigarray of zero dimension.
+ [kind] and [layout] determine the array element kind and the array
+ layout as described for {!Genarray.create}. *)
+
+ external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+ (** Return the kind of the given big array. *)
+
+ external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+ (** Return the layout of the given big array. *)
+
+ val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+ (** [Array0.change_layout a layout] returns a big array with the
+ specified [layout], sharing the data with [a]. No copying of elements
+ is involved: the new array and the original array share the same
+ storage space.
+
+ @since 4.06.0
+ *)
+
+ val size_in_bytes : ('a, 'b, 'c) t -> int
+ (** [size_in_bytes a] is [a]'s {!kind_size_in_bytes}. *)
+
+ val get: ('a, 'b, 'c) t -> 'a
+ (** [Array0.get a] returns the only element in [a]. *)
+
+ val set: ('a, 'b, 'c) t -> 'a -> unit
+ (** [Array0.set a x v] stores the value [v] in [a]. *)
+
+ external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
+ (** Copy the first big array to the second big array.
+ See {!Genarray.blit} for more details. *)
+
+ external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+ (** Fill the given big array with the given value.
+ See {!Genarray.fill} for more details. *)
+
+ val of_value: ('a, 'b) kind -> 'c layout -> 'a -> ('a, 'b, 'c) t
+ (** Build a zero-dimensional big array initialized from the
+ given value. *)
+
+end
+
+
+(** {1 One-dimensional arrays} *)
+
+(** One-dimensional arrays. The [Array1] structure provides operations
+ similar to those of
+ {!Bigarray.Genarray}, but specialized to the case of one-dimensional arrays.
+ (The {!Array2} and {!Array3} structures below provide operations
+ specialized for two- and three-dimensional arrays.)
+ Statically knowing the number of dimensions of the array allows
+ faster operations, and more precise static type-checking. *)
+module Array1 : sig
+ type ('a, 'b, 'c) t
+ (** The type of one-dimensional big arrays whose elements have
+ OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
+
+ val create: ('a, 'b) kind -> 'c layout -> int -> ('a, 'b, 'c) t
+ (** [Array1.create kind layout dim] returns a new bigarray of
+ one dimension, whose size is [dim]. [kind] and [layout]
+ determine the array element kind and the array layout
+ as described for {!Genarray.create}. *)
+
+ external dim: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+ (** Return the size (dimension) of the given one-dimensional
+ big array. *)
+
+ external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+ (** Return the kind of the given big array. *)
+
+ external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+ (** Return the layout of the given big array. *)
+
+ val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+ (** [Array1.change_layout a layout] returns a bigarray with the
+ specified [layout], sharing the data with [a] (and hence having
+ the same dimension as [a]). No copying of elements is involved: the
+ new array and the original array share the same storage space.
+
+ @since 4.06.0
+ *)
+
+
+ val size_in_bytes : ('a, 'b, 'c) t -> int
+ (** [size_in_bytes a] is the number of elements in [a]
+ multiplied by [a]'s {!kind_size_in_bytes}.
+
+ @since 4.03.0 *)
+
+ external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1"
+ (** [Array1.get a x], or alternatively [a.{x}],
+ returns the element of [a] at index [x].
+ [x] must be greater or equal than [0] and strictly less than
+ [Array1.dim a] if [a] has C layout. If [a] has Fortran layout,
+ [x] must be greater or equal than [1] and less or equal than
+ [Array1.dim a]. Otherwise, [Invalid_argument] is raised. *)
+
+ external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1"
+ (** [Array1.set a x v], also written [a.{x} <- v],
+ stores the value [v] at index [x] in [a].
+ [x] must be inside the bounds of [a] as described in
+ {!Bigarray.Array1.get};
+ otherwise, [Invalid_argument] is raised. *)
+
+ external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t
+ = "caml_ba_sub"
+ (** Extract a sub-array of the given one-dimensional big array.
+ See {!Genarray.sub_left} for more details. *)
+
+ val slice: ('a, 'b, 'c) t -> int -> ('a, 'b, 'c) Array0.t
+ (** Extract a scalar (zero-dimensional slice) of the given one-dimensional
+ big array. The integer parameter is the index of the scalar to
+ extract. See {!Bigarray.Genarray.slice_left} and
+ {!Bigarray.Genarray.slice_right} for more details.
+ @since 4.05.0 *)
+
+ external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
+ = "caml_ba_blit"
+ (** Copy the first big array to the second big array.
+ See {!Genarray.blit} for more details. *)
+
+ external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+ (** Fill the given big array with the given value.
+ See {!Genarray.fill} for more details. *)
+
+ val of_array: ('a, 'b) kind -> 'c layout -> 'a array -> ('a, 'b, 'c) t
+ (** Build a one-dimensional big array initialized from the
+ given array. *)
+
+ external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1"
+ (** Like {!Bigarray.Array1.get}, but bounds checking is not always performed.
+ Use with caution and only when the program logic guarantees that
+ the access is within bounds. *)
+
+ external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit
+ = "%caml_ba_unsafe_set_1"
+ (** Like {!Bigarray.Array1.set}, but bounds checking is not always performed.
+ Use with caution and only when the program logic guarantees that
+ the access is within bounds. *)
+
+end
+
+
+(** {1 Two-dimensional arrays} *)
+
+(** Two-dimensional arrays. The [Array2] structure provides operations
+ similar to those of {!Bigarray.Genarray}, but specialized to the
+ case of two-dimensional arrays. *)
+module Array2 :
+ sig
+ type ('a, 'b, 'c) t
+ (** The type of two-dimensional big arrays whose elements have
+ OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
+
+ val create: ('a, 'b) kind -> 'c layout -> int -> int -> ('a, 'b, 'c) t
+ (** [Array2.create kind layout dim1 dim2] returns a new bigarray of
+ two dimension, whose size is [dim1] in the first dimension
+ and [dim2] in the second dimension. [kind] and [layout]
+ determine the array element kind and the array layout
+ as described for {!Bigarray.Genarray.create}. *)
+
+ external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+ (** Return the first dimension of the given two-dimensional big array. *)
+
+ external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
+ (** Return the second dimension of the given two-dimensional big array. *)
+
+ external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+ (** Return the kind of the given big array. *)
+
+ external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+ (** Return the layout of the given big array. *)
+
+ val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+ (** [Array2.change_layout a layout] returns a bigarray with the
+ specified [layout], sharing the data with [a] (and hence having
+ the same dimensions as [a]). No copying of elements is involved: the
+ new array and the original array share the same storage space.
+ The dimensions are reversed, such that [get v [| a; b |]] in
+ C layout becomes [get v [| b+1; a+1 |]] in Fortran layout.
+
+ @since 4.06.0
+ *)
+
+
+ val size_in_bytes : ('a, 'b, 'c) t -> int
+ (** [size_in_bytes a] is the number of elements in [a]
+ multiplied by [a]'s {!kind_size_in_bytes}.
+
+ @since 4.03.0 *)
+
+ external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2"
+ (** [Array2.get a x y], also written [a.{x,y}],
+ returns the element of [a] at coordinates ([x], [y]).
+ [x] and [y] must be within the bounds
+ of [a], as described for {!Bigarray.Genarray.get};
+ otherwise, [Invalid_argument] is raised. *)
+
+ external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2"
+ (** [Array2.set a x y v], or alternatively [a.{x,y} <- v],
+ stores the value [v] at coordinates ([x], [y]) in [a].
+ [x] and [y] must be within the bounds of [a],
+ as described for {!Bigarray.Genarray.set};
+ otherwise, [Invalid_argument] is raised. *)
+
+ external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
+ = "caml_ba_sub"
+ (** Extract a two-dimensional sub-array of the given two-dimensional
+ big array by restricting the first dimension.
+ See {!Bigarray.Genarray.sub_left} for more details.
+ [Array2.sub_left] applies only to arrays with C layout. *)
+
+ external sub_right:
+ ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
+ = "caml_ba_sub"
+ (** Extract a two-dimensional sub-array of the given two-dimensional
+ big array by restricting the second dimension.
+ See {!Bigarray.Genarray.sub_right} for more details.
+ [Array2.sub_right] applies only to arrays with Fortran layout. *)
+
+ val slice_left: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array1.t
+ (** Extract a row (one-dimensional slice) of the given two-dimensional
+ big array. The integer parameter is the index of the row to
+ extract. See {!Bigarray.Genarray.slice_left} for more details.
+ [Array2.slice_left] applies only to arrays with C layout. *)
+
+ val slice_right:
+ ('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array1.t
+ (** Extract a column (one-dimensional slice) of the given
+ two-dimensional big array. The integer parameter is the
+ index of the column to extract. See {!Bigarray.Genarray.slice_right}
+ for more details. [Array2.slice_right] applies only to arrays
+ with Fortran layout. *)
+
+ external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
+ = "caml_ba_blit"
+ (** Copy the first big array to the second big array.
+ See {!Bigarray.Genarray.blit} for more details. *)
+
+ external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+ (** Fill the given big array with the given value.
+ See {!Bigarray.Genarray.fill} for more details. *)
+
+ val of_array: ('a, 'b) kind -> 'c layout -> 'a array array -> ('a, 'b, 'c) t
+ (** Build a two-dimensional big array initialized from the
+ given array of arrays. *)
+
+ external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a
+ = "%caml_ba_unsafe_ref_2"
+ (** Like {!Bigarray.Array2.get}, but bounds checking is not always
+ performed. *)
+
+ external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit
+ = "%caml_ba_unsafe_set_2"
+ (** Like {!Bigarray.Array2.set}, but bounds checking is not always
+ performed. *)
+
+end
+
+(** {1 Three-dimensional arrays} *)
+
+(** Three-dimensional arrays. The [Array3] structure provides operations
+ similar to those of {!Bigarray.Genarray}, but specialized to the case
+ of three-dimensional arrays. *)
+module Array3 :
+ sig
+ type ('a, 'b, 'c) t
+ (** The type of three-dimensional big arrays whose elements have
+ OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
+
+ val create: ('a, 'b) kind -> 'c layout -> int -> int -> int -> ('a, 'b, 'c) t
+ (** [Array3.create kind layout dim1 dim2 dim3] returns a new bigarray of
+ three dimension, whose size is [dim1] in the first dimension,
+ [dim2] in the second dimension, and [dim3] in the third.
+ [kind] and [layout] determine the array element kind and
+ the array layout as described for {!Bigarray.Genarray.create}. *)
+
+ external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+ (** Return the first dimension of the given three-dimensional big array. *)
+
+ external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
+ (** Return the second dimension of the given three-dimensional big array. *)
+
+ external dim3: ('a, 'b, 'c) t -> int = "%caml_ba_dim_3"
+ (** Return the third dimension of the given three-dimensional big array. *)
+
+ external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+ (** Return the kind of the given big array. *)
+
+ external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+ (** Return the layout of the given big array. *)
+
+
+ val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+ (** [Array3.change_layout a layout] returns a bigarray with the
+ specified [layout], sharing the data with [a] (and hence having
+ the same dimensions as [a]). No copying of elements is involved: the
+ new array and the original array share the same storage space.
+ The dimensions are reversed, such that [get v [| a; b; c |]] in
+ C layout becomes [get v [| c+1; b+1; a+1 |]] in Fortran layout.
+
+ @since 4.06.0
+ *)
+
+ val size_in_bytes : ('a, 'b, 'c) t -> int
+ (** [size_in_bytes a] is the number of elements in [a]
+ multiplied by [a]'s {!kind_size_in_bytes}.
+
+ @since 4.03.0 *)
+
+ external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3"
+ (** [Array3.get a x y z], also written [a.{x,y,z}],
+ returns the element of [a] at coordinates ([x], [y], [z]).
+ [x], [y] and [z] must be within the bounds of [a],
+ as described for {!Bigarray.Genarray.get};
+ otherwise, [Invalid_argument] is raised. *)
+
+ external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
+ = "%caml_ba_set_3"
+ (** [Array3.set a x y v], or alternatively [a.{x,y,z} <- v],
+ stores the value [v] at coordinates ([x], [y], [z]) in [a].
+ [x], [y] and [z] must be within the bounds of [a],
+ as described for {!Bigarray.Genarray.set};
+ otherwise, [Invalid_argument] is raised. *)
+
+ external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
+ = "caml_ba_sub"
+ (** Extract a three-dimensional sub-array of the given
+ three-dimensional big array by restricting the first dimension.
+ See {!Bigarray.Genarray.sub_left} for more details. [Array3.sub_left]
+ applies only to arrays with C layout. *)
+
+ external sub_right:
+ ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
+ = "caml_ba_sub"
+ (** Extract a three-dimensional sub-array of the given
+ three-dimensional big array by restricting the second dimension.
+ See {!Bigarray.Genarray.sub_right} for more details. [Array3.sub_right]
+ applies only to arrays with Fortran layout. *)
+
+ val slice_left_1:
+ ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) Array1.t
+ (** Extract a one-dimensional slice of the given three-dimensional
+ big array by fixing the first two coordinates.
+ The integer parameters are the coordinates of the slice to
+ extract. See {!Bigarray.Genarray.slice_left} for more details.
+ [Array3.slice_left_1] applies only to arrays with C layout. *)
+
+ val slice_right_1:
+ ('a, 'b, fortran_layout) t ->
+ int -> int -> ('a, 'b, fortran_layout) Array1.t
+ (** Extract a one-dimensional slice of the given three-dimensional
+ big array by fixing the last two coordinates.
+ The integer parameters are the coordinates of the slice to
+ extract. See {!Bigarray.Genarray.slice_right} for more details.
+ [Array3.slice_right_1] applies only to arrays with Fortran
+ layout. *)
+
+ val slice_left_2: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array2.t
+ (** Extract a two-dimensional slice of the given three-dimensional
+ big array by fixing the first coordinate.
+ The integer parameter is the first coordinate of the slice to
+ extract. See {!Bigarray.Genarray.slice_left} for more details.
+ [Array3.slice_left_2] applies only to arrays with C layout. *)
+
+ val slice_right_2:
+ ('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array2.t
+ (** Extract a two-dimensional slice of the given
+ three-dimensional big array by fixing the last coordinate.
+ The integer parameter is the coordinate of the slice
+ to extract. See {!Bigarray.Genarray.slice_right} for more details.
+ [Array3.slice_right_2] applies only to arrays with Fortran
+ layout. *)
+
+ external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
+ = "caml_ba_blit"
+ (** Copy the first big array to the second big array.
+ See {!Bigarray.Genarray.blit} for more details. *)
+
+ external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+ (** Fill the given big array with the given value.
+ See {!Bigarray.Genarray.fill} for more details. *)
+
+ val of_array:
+ ('a, 'b) kind -> 'c layout -> 'a array array array -> ('a, 'b, 'c) t
+ (** Build a three-dimensional big array initialized from the
+ given array of arrays of arrays. *)
+
+ external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a
+ = "%caml_ba_unsafe_ref_3"
+ (** Like {!Bigarray.Array3.get}, but bounds checking is not always
+ performed. *)
+
+ external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
+ = "%caml_ba_unsafe_set_3"
+ (** Like {!Bigarray.Array3.set}, but bounds checking is not always
+ performed. *)
+
+end
+
+(** {1 Coercions between generic big arrays and fixed-dimension big arrays} *)
+
+external genarray_of_array0 :
+ ('a, 'b, 'c) Array0.t -> ('a, 'b, 'c) Genarray.t = "%identity"
+(** Return the generic big array corresponding to the given zero-dimensional
+ big array. @since 4.05.0 *)
+
+external genarray_of_array1 :
+ ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t = "%identity"
+(** Return the generic big array corresponding to the given one-dimensional
+ big array. *)
+
+external genarray_of_array2 :
+ ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t = "%identity"
+(** Return the generic big array corresponding to the given two-dimensional
+ big array. *)
+
+external genarray_of_array3 :
+ ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t = "%identity"
+(** Return the generic big array corresponding to the given three-dimensional
+ big array. *)
+
+val array0_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array0.t
+(** Return the zero-dimensional big array corresponding to the given
+ generic big array. Raise [Invalid_argument] if the generic big array
+ does not have exactly zero dimension.
+ @since 4.05.0 *)
+
+val array1_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array1.t
+(** Return the one-dimensional big array corresponding to the given
+ generic big array. Raise [Invalid_argument] if the generic big array
+ does not have exactly one dimension. *)
+
+val array2_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array2.t
+(** Return the two-dimensional big array corresponding to the given
+ generic big array. Raise [Invalid_argument] if the generic big array
+ does not have exactly two dimensions. *)
+
+val array3_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array3.t
+(** Return the three-dimensional big array corresponding to the given
+ generic big array. Raise [Invalid_argument] if the generic big array
+ does not have exactly three dimensions. *)
+
+
+(** {1 Re-shaping big arrays} *)
+
+val reshape : ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t
+(** [reshape b [|d1;...;dN|]] converts the big array [b] to a
+ [N]-dimensional array of dimensions [d1]...[dN]. The returned
+ array and the original array [b] share their data
+ and have the same layout. For instance, assuming that [b]
+ is a one-dimensional array of dimension 12, [reshape b [|3;4|]]
+ returns a two-dimensional array [b'] of dimensions 3 and 4.
+ If [b] has C layout, the element [(x,y)] of [b'] corresponds
+ to the element [x * 3 + y] of [b]. If [b] has Fortran layout,
+ the element [(x,y)] of [b'] corresponds to the element
+ [x + (y - 1) * 4] of [b].
+ The returned big array must have exactly the same number of
+ elements as the original big array [b]. That is, the product
+ of the dimensions of [b] must be equal to [i1 * ... * iN].
+ Otherwise, [Invalid_argument] is raised. *)
+
+val reshape_0 : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array0.t
+(** Specialized version of {!Bigarray.reshape} for reshaping to
+ zero-dimensional arrays.
+ @since 4.05.0 *)
+
+val reshape_1 : ('a, 'b, 'c) Genarray.t -> int -> ('a, 'b, 'c) Array1.t
+(** Specialized version of {!Bigarray.reshape} for reshaping to
+ one-dimensional arrays. *)
+
+val reshape_2 : ('a, 'b, 'c) Genarray.t -> int -> int -> ('a, 'b, 'c) Array2.t
+(** Specialized version of {!Bigarray.reshape} for reshaping to
+ two-dimensional arrays. *)
+
+val reshape_3 :
+ ('a, 'b, 'c) Genarray.t -> int -> int -> int -> ('a, 'b, 'c) Array3.t
+(** Specialized version of {!Bigarray.reshape} for reshaping to
+ three-dimensional arrays. *)
invalid_arg "Buffer.truncate"
else
b.position <- len
+
+(** {6 Iterators} *)
+
+let to_seq b =
+ let rec aux i () =
+ if i >= b.position then Seq.Nil
+ else
+ let x = Bytes.get b.buffer i in
+ Seq.Cons (x, aux (i+1))
+ in
+ aux 0
+
+let to_seqi b =
+ let rec aux i () =
+ if i >= b.position then Seq.Nil
+ else
+ let x = Bytes.get b.buffer i in
+ Seq.Cons ((i,x), aux (i+1))
+ in
+ aux 0
+
+let add_seq b seq = Seq.iter (add_char b) seq
+
+let of_seq i =
+ let b = create 32 in
+ add_seq b i;
+ b
+
Note: the internal byte sequence is not shortened.
Raise [Invalid_argument] if [len < 0] or [len > length b].
@since 4.05.0 *)
+
+(** {6 Iterators} *)
+
+val to_seq : t -> char Seq.t
+(** Iterate on the buffer, in increasing order.
+ Modification of the buffer during iteration is undefined behavior.
+ @since 4.07 *)
+
+val to_seqi : t -> (int * char) Seq.t
+(** Iterate on the buffer, in increasing order, yielding indices along chars.
+ Modification of the buffer during iteration is undefined behavior.
+ @since 4.07 *)
+
+val add_seq : t -> char Seq.t -> unit
+(** Add chars to the buffer
+ @since 4.07 *)
+
+val of_seq : char Seq.t -> t
+(** Create a buffer from the generator
+ @since 4.07 *)
+
let capitalize s = apply1 Char.uppercase s
let uncapitalize s = apply1 Char.lowercase s
+
+(** {6 Iterators} *)
+
+let to_seq s =
+ let rec aux i () =
+ if i = length s then Seq.Nil
+ else
+ let x = get s i in
+ Seq.Cons (x, aux (i+1))
+ in
+ aux 0
+
+let to_seqi s =
+ let rec aux i () =
+ if i = length s then Seq.Nil
+ else
+ let x = get s i in
+ Seq.Cons ((i,x), aux (i+1))
+ in
+ aux 0
+
+let of_seq i =
+ let n = ref 0 in
+ let buf = ref (make 256 '\000') in
+ let resize () =
+ (* resize *)
+ let new_len = min (2 * length !buf) Sys.max_string_length in
+ if length !buf = new_len then failwith "Bytes.of_seq: cannot grow bytes";
+ let new_buf = make new_len '\000' in
+ blit !buf 0 new_buf 0 !n;
+ buf := new_buf
+ in
+ Seq.iter
+ (fun c ->
+ if !n = length !buf then resize();
+ set !buf !n c;
+ incr n)
+ i;
+ sub !buf 0 !n
+
[string] type for this purpose.
*)
+(** {6 Iterators} *)
+
+val to_seq : t -> char Seq.t
+(** Iterate on the string, in increasing index order. Modifications of the
+ string during iteration will be reflected in the iterator.
+ @since 4.07 *)
+
+val to_seqi : t -> (int * char) Seq.t
+(** Iterate on the string, in increasing order, yielding indices along chars
+ @since 4.07 *)
+
+val of_seq : char Seq.t -> t
+(** Create a string from the generator
+ @since 4.07 *)
+
(**/**)
(* The following is for system use only. Do not call directly. *)
(** The equality function for byte sequences.
@since 4.05.0 *)
+(** {6 Iterators} *)
+
+val to_seq : t -> char Seq.t
+(** Iterate on the string, in increasing index order. Modifications of the
+ string during iteration will be reflected in the iterator.
+ @since 4.07 *)
+
+val to_seqi : t -> (int * char) Seq.t
+(** Iterate on the string, in increasing order, yielding indices along chars
+ @since 4.07 *)
+
+val of_seq : char Seq.t -> t
+(** Create a string from the generator
+ @since 4.07 *)
+
(**/**)
(* The following is for system use only. Do not call directly. *)
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2000 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(* Bigarray types. These must be kept in sync with the tables in
- ../typing/typeopt.ml *)
-
-type float32_elt = Float32_elt
-type float64_elt = Float64_elt
-type int8_signed_elt = Int8_signed_elt
-type int8_unsigned_elt = Int8_unsigned_elt
-type int16_signed_elt = Int16_signed_elt
-type int16_unsigned_elt = Int16_unsigned_elt
-type int32_elt = Int32_elt
-type int64_elt = Int64_elt
-type int_elt = Int_elt
-type nativeint_elt = Nativeint_elt
-type complex32_elt = Complex32_elt
-type complex64_elt = Complex64_elt
-
-type ('a, 'b) kind =
- Float32 : (float, float32_elt) kind
- | Float64 : (float, float64_elt) kind
- | Int8_signed : (int, int8_signed_elt) kind
- | Int8_unsigned : (int, int8_unsigned_elt) kind
- | Int16_signed : (int, int16_signed_elt) kind
- | Int16_unsigned : (int, int16_unsigned_elt) kind
- | Int32 : (int32, int32_elt) kind
- | Int64 : (int64, int64_elt) kind
- | Int : (int, int_elt) kind
- | Nativeint : (nativeint, nativeint_elt) kind
- | Complex32 : (Complex.t, complex32_elt) kind
- | Complex64 : (Complex.t, complex64_elt) kind
- | Char : (char, int8_unsigned_elt) kind
-
-type c_layout = C_layout_typ
-type fortran_layout = Fortran_layout_typ
-
-type 'a layout =
- C_layout: c_layout layout
- | Fortran_layout: fortran_layout layout
-
-type ('a, 'b, 'c) genarray
max_bucket_length = mbl;
bucket_histogram = histo }
+ let to_seq tbl =
+ (* capture current array, so that even if the table is resized we
+ keep iterating on the same array *)
+ let tbl_data = tbl.data in
+ (* state: index * next bucket to traverse *)
+ let rec aux i buck () = match buck with
+ | Empty ->
+ if i = Array.length tbl_data
+ then Seq.Nil
+ else aux(i+1) tbl_data.(i) ()
+ | Cons (_, c, next) ->
+ begin match H.get_key c, H.get_data c with
+ | None, _ | _, None -> aux i next ()
+ | Some key, Some data ->
+ Seq.Cons ((key, data), aux i next)
+ end
+ in
+ aux 0 Empty
+
+ let to_seq_keys m = Seq.map fst (to_seq m)
+
+ let to_seq_values m = Seq.map snd (to_seq m)
+
+ let add_seq tbl i =
+ Seq.iter (fun (k,v) -> add tbl k v) i
+
+ let replace_seq tbl i =
+ Seq.iter (fun (k,v) -> replace tbl k v) i
+
+ let of_seq i =
+ let tbl = create 16 in
+ replace_seq tbl i;
+ tbl
end
end
--- /dev/null
+#**************************************************************************
+#* *
+#* OCaml *
+#* *
+#* Jeremie Dimino, Jane Street Europe *
+#* *
+#* Copyright 2017 Jane Street Group LLC *
+#* *
+#* All rights reserved. This file is distributed under the terms of *
+#* the GNU Lesser General Public License version 2.1, with the *
+#* special exception on linking described in the file LICENSE. *
+#* *
+#**************************************************************************
+
+# This script adds the Stdlib__ prefixes to the module aliases in
+# stdlib.ml and stdlib.mli
+BEGIN { state=0 }
+NR == 1 { printf ("# 1 \"%s\"\n", FILENAME) }
+/\(\*MODULE_ALIASES\*\)\r?/ { state=1 }
+{ if (state==0)
+ print;
+ else if (state==1)
+ state=2;
+ else if ($1 == "module")
+ printf ("\n(** @canonical %s *)\nmodule %s = Stdlib__%s%s\n",
+ $2, $2, tolower(substr($4,1,1)), substr($4,2));
+}
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* Nicolas Ojeda Bar, LexiFi *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+external neg : float -> float = "%negfloat"
+external add : float -> float -> float = "%addfloat"
+external sub : float -> float -> float = "%subfloat"
+external mul : float -> float -> float = "%mulfloat"
+external div : float -> float -> float = "%divfloat"
+external rem : float -> float -> float = "caml_fmod_float" "fmod"
+ [@@unboxed] [@@noalloc]
+external abs : float -> float = "%absfloat"
+let infinity = Pervasives.infinity
+let neg_infinity = Pervasives.neg_infinity
+let nan = Pervasives.nan
+let pi = 0x1.921fb54442d18p+1
+let max_float = Pervasives.max_float
+let min_float = Pervasives.min_float
+let epsilon = Pervasives.epsilon_float
+external of_int : int -> float = "%floatofint"
+external to_int : float -> int = "%intoffloat"
+external of_string : string -> float = "caml_float_of_string"
+let of_string_opt = Pervasives.float_of_string_opt
+let to_string = Pervasives.string_of_float
+type fpclass = Pervasives.fpclass =
+ FP_normal
+ | FP_subnormal
+ | FP_zero
+ | FP_infinite
+ | FP_nan
+external classify_float : (float [@unboxed]) -> fpclass =
+ "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
+external pow : float -> float -> float = "caml_power_float" "pow"
+ [@@unboxed] [@@noalloc]
+external sqrt : float -> float = "caml_sqrt_float" "sqrt"
+ [@@unboxed] [@@noalloc]
+external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc]
+external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc]
+external log10 : float -> float = "caml_log10_float" "log10"
+ [@@unboxed] [@@noalloc]
+external expm1 : float -> float = "caml_expm1_float" "caml_expm1"
+ [@@unboxed] [@@noalloc]
+external log1p : float -> float = "caml_log1p_float" "caml_log1p"
+ [@@unboxed] [@@noalloc]
+external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc]
+external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc]
+external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc]
+external acos : float -> float = "caml_acos_float" "acos"
+ [@@unboxed] [@@noalloc]
+external asin : float -> float = "caml_asin_float" "asin"
+ [@@unboxed] [@@noalloc]
+external atan : float -> float = "caml_atan_float" "atan"
+ [@@unboxed] [@@noalloc]
+external atan2 : float -> float -> float = "caml_atan2_float" "atan2"
+ [@@unboxed] [@@noalloc]
+external hypot : float -> float -> float
+ = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc]
+external cosh : float -> float = "caml_cosh_float" "cosh"
+ [@@unboxed] [@@noalloc]
+external sinh : float -> float = "caml_sinh_float" "sinh"
+ [@@unboxed] [@@noalloc]
+external tanh : float -> float = "caml_tanh_float" "tanh"
+ [@@unboxed] [@@noalloc]
+external ceil : float -> float = "caml_ceil_float" "ceil"
+ [@@unboxed] [@@noalloc]
+external floor : float -> float = "caml_floor_float" "floor"
+[@@unboxed] [@@noalloc]
+external copysign : float -> float -> float
+ = "caml_copysign_float" "caml_copysign"
+ [@@unboxed] [@@noalloc]
+external frexp : float -> float * int = "caml_frexp_float"
+external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
+ "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc]
+external modf : float -> float * float = "caml_modf_float"
+type t = float
+external compare : float -> float -> int = "%compare"
+let equal x y = compare x y = 0
+external seeded_hash_param : int -> int -> int -> float -> int = "caml_hash" [@@noalloc]
+let hash x = seeded_hash_param 10 100 0 x
+
+module Array = struct
+ type t = floatarray
+ external create : int -> t = "caml_floatarray_create"
+ external length : t -> int = "%floatarray_length"
+ external get : t -> int -> float = "%floatarray_safe_get"
+ external set : t -> int -> float -> unit = "%floatarray_safe_set"
+ external unsafe_get : t -> int -> float = "%floatarray_unsafe_get"
+ external unsafe_set : t -> int -> float -> unit = "%floatarray_unsafe_set"
+end
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* Nicolas Ojeda Bar, LexiFi *)
+(* *)
+(* Copyright 2018 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(** {1 Floating-point arithmetic}
+
+ OCaml's floating-point numbers follow the
+ IEEE 754 standard, using double precision (64 bits) numbers.
+ Floating-point operations never raise an exception on overflow,
+ underflow, division by zero, etc. Instead, special IEEE numbers
+ are returned as appropriate, such as [infinity] for [1.0 /. 0.0],
+ [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number')
+ for [0.0 /. 0.0]. These special numbers then propagate through
+ floating-point computations as expected: for instance,
+ [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan]
+ as argument returns [nan] as result.
+
+ @since 4.07.0
+*)
+
+external neg : float -> float = "%negfloat"
+(** Unary negation. *)
+
+external add : float -> float -> float = "%addfloat"
+(** Floating-point addition. *)
+
+external sub : float -> float -> float = "%subfloat"
+(** Floating-point subtraction. *)
+
+external mul : float -> float -> float = "%mulfloat"
+(** Floating-point multiplication. *)
+
+external div : float -> float -> float = "%divfloat"
+(** Floating-point division. *)
+
+external rem : float -> float -> float = "caml_fmod_float" "fmod"
+[@@unboxed] [@@noalloc]
+(** [rem a b] returns the remainder of [a] with respect to [b]. The returned
+ value is [a -. n *. b], where [n] is the quotient [a /. b] rounded towards
+ zero to an integer. *)
+
+external abs : float -> float = "%absfloat"
+(** [abs f] returns the absolute value of [f]. *)
+
+val infinity : float
+(** Positive infinity. *)
+
+val neg_infinity : float
+(** Negative infinity. *)
+
+val nan : float
+(** A special floating-point value denoting the result of an
+ undefined operation such as [0.0 /. 0.0]. Stands for
+ 'not a number'. Any floating-point operation with [nan] as
+ argument returns [nan] as result. As for floating-point comparisons,
+ [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true]
+ if one or both of their arguments is [nan]. *)
+
+val pi : float
+(** The constant pi. *)
+
+val max_float : float
+(** The largest positive finite value of type [float]. *)
+
+val min_float : float
+(** The smallest positive, non-zero, non-denormalized value of type [float]. *)
+
+val epsilon : float
+(** The difference between [1.0] and the smallest exactly representable
+ floating-point number greater than [1.0]. *)
+
+external of_int : int -> float = "%floatofint"
+(** Convert an integer to floating-point. *)
+
+external to_int : float -> int = "%intoffloat"
+(** Truncate the given floating-point number to an integer.
+ The result is unspecified if the argument is [nan] or falls outside the
+ range of representable integers. *)
+
+external of_string : string -> float = "caml_float_of_string"
+(** Convert the given string to a float. The string is read in decimal
+ (by default) or in hexadecimal (marked by [0x] or [0X]).
+ The format of decimal floating-point numbers is
+ [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit.
+ The format of hexadecimal floating-point numbers is
+ [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an
+ hexadecimal digit and [d] for a decimal digit.
+ In both cases, at least one of the integer and fractional parts must be
+ given; the exponent part is optional.
+ The [_] (underscore) character can appear anywhere in the string
+ and is ignored.
+ Depending on the execution platforms, other representations of
+ floating-point numbers can be accepted, but should not be relied upon.
+ Raise [Failure "float_of_string"] if the given string is not a valid
+ representation of a float. *)
+
+val of_string_opt: string -> float option
+(** Same as [of_string], but returns [None] instead of raising. *)
+
+val to_string : float -> string
+(** Return the string representation of a floating-point number. *)
+
+type fpclass = Pervasives.fpclass =
+ FP_normal (** Normal number, none of the below *)
+ | FP_subnormal (** Number very close to 0.0, has reduced precision *)
+ | FP_zero (** Number is 0.0 or -0.0 *)
+ | FP_infinite (** Number is positive or negative infinity *)
+ | FP_nan (** Not a number: result of an undefined operation *)
+(** The five classes of floating-point numbers, as determined by
+ the {!classify_float} function. *)
+
+external classify_float : (float [@unboxed]) -> fpclass =
+ "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
+(** Return the class of the given floating-point number:
+ normal, subnormal, zero, infinite, or not a number. *)
+
+external pow : float -> float -> float = "caml_power_float" "pow"
+[@@unboxed] [@@noalloc]
+(** Exponentiation. *)
+
+external sqrt : float -> float = "caml_sqrt_float" "sqrt"
+[@@unboxed] [@@noalloc]
+(** Square root. *)
+
+external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc]
+(** Exponential. *)
+
+external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc]
+(** Natural logarithm. *)
+
+external log10 : float -> float = "caml_log10_float" "log10"
+[@@unboxed] [@@noalloc]
+(** Base 10 logarithm. *)
+
+external expm1 : float -> float = "caml_expm1_float" "caml_expm1"
+[@@unboxed] [@@noalloc]
+(** [expm1 x] computes [exp x -. 1.0], giving numerically-accurate results
+ even if [x] is close to [0.0]. *)
+
+external log1p : float -> float = "caml_log1p_float" "caml_log1p"
+[@@unboxed] [@@noalloc]
+(** [log1p x] computes [log(1.0 +. x)] (natural logarithm),
+ giving numerically-accurate results even if [x] is close to [0.0]. *)
+
+external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc]
+(** Cosine. Argument is in radians. *)
+
+external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc]
+(** Sine. Argument is in radians. *)
+
+external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc]
+(** Tangent. Argument is in radians. *)
+
+external acos : float -> float = "caml_acos_float" "acos"
+[@@unboxed] [@@noalloc]
+(** Arc cosine. The argument must fall within the range [[-1.0, 1.0]].
+ Result is in radians and is between [0.0] and [pi]. *)
+
+external asin : float -> float = "caml_asin_float" "asin"
+[@@unboxed] [@@noalloc]
+(** Arc sine. The argument must fall within the range [[-1.0, 1.0]].
+ Result is in radians and is between [-pi/2] and [pi/2]. *)
+
+external atan : float -> float = "caml_atan_float" "atan"
+[@@unboxed] [@@noalloc]
+(** Arc tangent.
+ Result is in radians and is between [-pi/2] and [pi/2]. *)
+
+external atan2 : float -> float -> float = "caml_atan2_float" "atan2"
+[@@unboxed] [@@noalloc]
+(** [atan2 y x] returns the arc tangent of [y /. x]. The signs of [x]
+ and [y] are used to determine the quadrant of the result.
+ Result is in radians and is between [-pi] and [pi]. *)
+
+external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot"
+[@@unboxed] [@@noalloc]
+(** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length
+ of the hypotenuse of a right-angled triangle with sides of length
+ [x] and [y], or, equivalently, the distance of the point [(x,y)]
+ to origin. If one of [x] or [y] is infinite, returns [infinity]
+ even if the other is [nan]. *)
+
+external cosh : float -> float = "caml_cosh_float" "cosh"
+[@@unboxed] [@@noalloc]
+(** Hyperbolic cosine. Argument is in radians. *)
+
+external sinh : float -> float = "caml_sinh_float" "sinh"
+[@@unboxed] [@@noalloc]
+(** Hyperbolic sine. Argument is in radians. *)
+
+external tanh : float -> float = "caml_tanh_float" "tanh"
+[@@unboxed] [@@noalloc]
+(** Hyperbolic tangent. Argument is in radians. *)
+
+external ceil : float -> float = "caml_ceil_float" "ceil"
+[@@unboxed] [@@noalloc]
+(** Round above to an integer value.
+ [ceil f] returns the least integer value greater than or equal to [f].
+ The result is returned as a float. *)
+
+external floor : float -> float = "caml_floor_float" "floor"
+[@@unboxed] [@@noalloc]
+(** Round below to an integer value.
+ [floor f] returns the greatest integer value less than or
+ equal to [f].
+ The result is returned as a float. *)
+
+external copysign : float -> float -> float
+ = "caml_copysign_float" "caml_copysign"
+[@@unboxed] [@@noalloc]
+(** [copysign x y] returns a float whose absolute value is that of [x]
+ and whose sign is that of [y]. If [x] is [nan], returns [nan].
+ If [y] is [nan], returns either [x] or [-. x], but it is not
+ specified which. *)
+
+external frexp : float -> float * int = "caml_frexp_float"
+(** [frexp f] returns the pair of the significant
+ and the exponent of [f]. When [f] is zero, the
+ significant [x] and the exponent [n] of [f] are equal to
+ zero. When [f] is non-zero, they are defined by
+ [f = x *. 2 ** n] and [0.5 <= x < 1.0]. *)
+
+external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
+ "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc]
+(** [ldexp x n] returns [x *. 2 ** n]. *)
+
+external modf : float -> float * float = "caml_modf_float"
+(** [modf f] returns the pair of the fractional and integral
+ part of [f]. *)
+
+type t = float
+(** An alias for the type of floating-point numbers. *)
+
+val compare: t -> t -> int
+(** [compare x y] returns [0] if [x] is equal to [y], a negative integer if [x]
+ is less than [y], and a positive integer if [x] is greater than
+ [y]. [compare] treats [nan] as equal to itself and less than any other float
+ value. This treatment of [nan] ensures that [compare] defines a total
+ ordering relation. *)
+
+val equal: t -> t -> bool
+(** The equal function for floating-point numbers, compared using {!compare}. *)
+
+val hash: t -> int
+(** The hash function for floating-point numbers. *)
+
+module Array : sig
+ type t = floatarray
+ external create : int -> t = "caml_floatarray_create"
+ external length : t -> int = "%floatarray_length"
+ external get : t -> int -> float = "%floatarray_safe_get"
+ external set : t -> int -> float -> unit = "%floatarray_safe_set"
+ external unsafe_get : t -> int -> float = "%floatarray_unsafe_get"
+ external unsafe_set : t -> int -> float -> unit = "%floatarray_unsafe_set"
+end
max_bucket_length = mbl;
bucket_histogram = histo }
+(** {6 Iterators} *)
+
+let to_seq tbl =
+ (* capture current array, so that even if the table is resized we
+ keep iterating on the same array *)
+ let tbl_data = tbl.data in
+ (* state: index * next bucket to traverse *)
+ let rec aux i buck () = match buck with
+ | Empty ->
+ if i = Array.length tbl_data
+ then Seq.Nil
+ else aux(i+1) tbl_data.(i) ()
+ | Cons {key; data; next} ->
+ Seq.Cons ((key, data), aux i next)
+ in
+ aux 0 Empty
+
+let to_seq_keys m = Seq.map fst (to_seq m)
+
+let to_seq_values m = Seq.map snd (to_seq m)
+
+let add_seq tbl i =
+ Seq.iter (fun (k,v) -> add tbl k v) i
+
+let replace_seq tbl i =
+ Seq.iter (fun (k,v) -> replace tbl k v) i
+
+let of_seq i =
+ let tbl = create 16 in
+ replace_seq tbl i;
+ tbl
+
(* Functorial interface *)
module type HashedType =
val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val length: 'a t -> int
val stats: 'a t -> statistics
+ val to_seq : 'a t -> (key * 'a) Seq.t
+ val to_seq_keys : _ t -> key Seq.t
+ val to_seq_values : 'a t -> 'a Seq.t
+ val add_seq : 'a t -> (key * 'a) Seq.t -> unit
+ val replace_seq : 'a t -> (key * 'a) Seq.t -> unit
+ val of_seq : (key * 'a) Seq.t -> 'a t
end
module type SeededS =
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val length : 'a t -> int
val stats: 'a t -> statistics
+ val to_seq : 'a t -> (key * 'a) Seq.t
+ val to_seq_keys : _ t -> key Seq.t
+ val to_seq_values : 'a t -> 'a Seq.t
+ val add_seq : 'a t -> (key * 'a) Seq.t -> unit
+ val replace_seq : 'a t -> (key * 'a) Seq.t -> unit
+ val of_seq : (key * 'a) Seq.t -> 'a t
end
module MakeSeeded(H: SeededHashedType): (SeededS with type key = H.t) =
let fold = fold
let length = length
let stats = stats
+ let to_seq = to_seq
+ let to_seq_keys = to_seq_keys
+ let to_seq_values = to_seq_values
+ let add_seq = add_seq
+ let replace_seq = replace_seq
+ let of_seq = of_seq
end
module Make(H: HashedType): (S with type key = H.t) =
buckets by size.
@since 4.00.0 *)
+(** {6 Iterators} *)
+
+val to_seq : ('a,'b) t -> ('a * 'b) Seq.t
+(** Iterate on the whole table, in unspecified order.
+
+ The behavior is not defined if the hash table is modified
+ during the iteration.
+
+ @since 4.07 *)
+
+val to_seq_keys : ('a,_) t -> 'a Seq.t
+(** Iterate on 'as, in ascending order
+ @since 4.07 *)
+
+val to_seq_values : (_,'b) t -> 'b Seq.t
+(** Iterate on values, in ascending order of their corresponding 'a
+ @since 4.07 *)
+
+val add_seq : ('a,'b) t -> ('a * 'b) Seq.t -> unit
+(** Add the given bindings to the table, using {!add}
+ @since 4.07 *)
+
+val replace_seq : ('a,'b) t -> ('a * 'b) Seq.t -> unit
+(** Add the given bindings to the table, using {!replace}
+ @since 4.07 *)
+
+val of_seq : ('a * 'b) Seq.t -> ('a, 'b) t
+(** Build a table from the given bindings. The bindings are added
+ in the same order they appear in the sequence, using {!replace_seq},
+ which means that if two pairs have the same key, only the latest one
+ will appear in the table.
+ @since 4.07 *)
+
(** {1 Functorial interface} *)
(** The functorial interface allows the use of specific comparison
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val length : 'a t -> int
val stats: 'a t -> statistics (** @since 4.00.0 *)
+
+ val to_seq : 'a t -> (key * 'a) Seq.t
+ (** @since 4.07 *)
+
+ val to_seq_keys : _ t -> key Seq.t
+ (** @since 4.07 *)
+
+ val to_seq_values : 'a t -> 'a Seq.t
+ (** @since 4.07 *)
+
+ val add_seq : 'a t -> (key * 'a) Seq.t -> unit
+ (** @since 4.07 *)
+
+ val replace_seq : 'a t -> (key * 'a) Seq.t -> unit
+ (** @since 4.07 *)
+
+ val of_seq : (key * 'a) Seq.t -> 'a t
+ (** @since 4.07 *)
end
(** The output signature of the functor {!Hashtbl.Make}. *)
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val length : 'a t -> int
val stats: 'a t -> statistics
+
+ val to_seq : 'a t -> (key * 'a) Seq.t
+ (** @since 4.07 *)
+
+ val to_seq_keys : _ t -> key Seq.t
+ (** @since 4.07 *)
+
+ val to_seq_values : 'a t -> 'a Seq.t
+ (** @since 4.07 *)
+
+ val add_seq : 'a t -> (key * 'a) Seq.t -> unit
+ (** @since 4.07 *)
+
+ val replace_seq : 'a t -> (key * 'a) Seq.t -> unit
+ (** @since 4.07 *)
+
+ val of_seq : (key * 'a) Seq.t -> 'a t
+ (** @since 4.07 *)
end
(** The output signature of the functor {!Hashtbl.MakeSeeded}.
@since 4.00.0 *)
let r = f i in
r :: init_aux (i+1) n f
+let rev_init_threshold =
+ match Sys.backend_type with
+ | Sys.Native | Sys.Bytecode -> 10_000
+ (* We don't known the size of the stack, better be safe and assume it's small. *)
+ | Sys.Other _ -> 50
+
let init len f =
if len < 0 then invalid_arg "List.init" else
- if len > 10_000 then rev (init_tailrec_aux [] 0 len f)
+ if len > rev_init_threshold then rev (init_tailrec_aux [] 0 len f)
else init_aux 0 len f
let rec flatten = function
if n <= 0 then 1 else
compare_length_with l (n-1)
;;
+
+(** {6 Iterators} *)
+
+let to_seq l =
+ let rec aux l () = match l with
+ | [] -> Seq.Nil
+ | x :: tail -> Seq.Cons (x, aux tail)
+ in
+ aux l
+
+let of_seq seq =
+ let rec direct depth seq : _ list =
+ if depth=0
+ then
+ Seq.fold_left (fun acc x -> x::acc) [] seq
+ |> rev (* tailrec *)
+ else match seq() with
+ | Seq.Nil -> []
+ | Seq.Cons (x, next) -> x :: direct (depth-1) next
+ in
+ direct 500 seq
before the elements of [l2].
Not tail-recursive (sum of the lengths of the arguments).
*)
+
+(** {6 Iterators} *)
+
+val to_seq : 'a list -> 'a Seq.t
+(** Iterate on the list
+ @since 4.07 *)
+
+val of_seq : 'a Seq.t -> 'a list
+(** Create a list from the iterator
+ @since 4.07 *)
before the elements of [l2].
Not tail-recursive (sum of the lengths of the arguments).
*)
+
+(** {6 Iterators} *)
+
+val to_seq : 'a list -> 'a Seq.t
+(** Iterate on the list
+ @since 4.07 *)
+
+val of_seq : 'a Seq.t -> 'a list
+(** Create a list from the iterator
+ @since 4.07 *)
val find_last_opt: (key -> bool) -> 'a t -> (key * 'a) option
val map: ('a -> 'b) -> 'a t -> 'b t
val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
+ val to_seq : 'a t -> (key * 'a) Seq.t
+ val to_seq_from : key -> 'a t -> (key * 'a) Seq.t
+ val add_seq : (key * 'a) Seq.t -> 'a t -> 'a t
+ val of_seq : (key * 'a) Seq.t -> 'a t
end
module Make(Ord: OrderedType) = struct
let choose_opt = min_binding_opt
+ let add_seq i m =
+ Seq.fold_left (fun m (k,v) -> add k v m) m i
+
+ let of_seq i = add_seq i empty
+
+ let rec seq_of_enum_ c () = match c with
+ | End -> Seq.Nil
+ | More (k,v,t,rest) -> Seq.Cons ((k,v), seq_of_enum_ (cons_enum t rest))
+
+ let to_seq m =
+ seq_of_enum_ (cons_enum m End)
+
+ let to_seq_from low m =
+ let rec aux low m c = match m with
+ | Empty -> c
+ | Node {l; v; d; r; _} ->
+ begin match Ord.compare v low with
+ | 0 -> More (v, d, r, c)
+ | n when n<0 -> aux low r c
+ | _ -> aux low l (More (v, d, r, c))
+ end
+ in
+ seq_of_enum_ (aux low m End)
end
(** Same as {!Map.S.map}, but the function receives as arguments both the
key and the associated value for each binding of the map. *)
+ (** {6 Iterators} *)
+ val to_seq : 'a t -> (key * 'a) Seq.t
+ (** Iterate on the whole map, in ascending order
+ @since 4.07 *)
+
+ val to_seq_from : key -> 'a t -> (key * 'a) Seq.t
+ (** [to_seq_from k m] iterates on a subset of the bindings of [m],
+ in ascending order, from key [k] or above.
+ @since 4.07 *)
+
+ val add_seq : (key * 'a) Seq.t -> 'a t -> 'a t
+ (** Add the given bindings to the map, in order.
+ @since 4.07 *)
+
+ val of_seq : (key * 'a) Seq.t -> 'a t
+ (** Build a map from the given bindings
+ @since 4.07 *)
end
(** Output signature of the functor {!Map.Make}. *)
external to_channel: out_channel -> 'a -> extern_flags list -> unit
= "caml_output_value"
external to_bytes: 'a -> extern_flags list -> bytes
- = "caml_output_value_to_string"
+ = "caml_output_value_to_bytes"
external to_string: 'a -> extern_flags list -> string
= "caml_output_value_to_string"
external to_buffer_unsafe:
*)
external from_channel: in_channel -> 'a = "caml_input_value"
-external from_bytes_unsafe: bytes -> int -> 'a
- = "caml_input_value_from_string"
+external from_bytes_unsafe: bytes -> int -> 'a = "caml_input_value_from_bytes"
external data_size_unsafe: bytes -> int -> int = "caml_marshal_data_size"
let header_size = 20
*)
external to_bytes :
- 'a -> extern_flags list -> bytes = "caml_output_value_to_string"
+ 'a -> extern_flags list -> bytes = "caml_output_value_to_bytes"
(** [Marshal.to_bytes v flags] returns a byte sequence containing
the representation of [v].
The [flags] argument has the same meaning as for
val is_randomized : unit -> bool
type statistics = Hashtbl.statistics
val stats : ('a, 'b) t -> statistics
+ val to_seq : ('a,'b) t -> ('a * 'b) Seq.t
+ val to_seq_keys : ('a,_) t -> 'a Seq.t
+ val to_seq_values : (_,'b) t -> 'b Seq.t
+ val add_seq : ('a,'b) t -> ('a * 'b) Seq.t -> unit
+ val replace_seq : ('a,'b) t -> ('a * 'b) Seq.t -> unit
+ val of_seq : ('a * 'b) Seq.t -> ('a, 'b) t
module type HashedType = Hashtbl.HashedType
module type SeededHashedType = Hashtbl.SeededHashedType
module type S =
'a t -> init:'b -> 'b
val length : 'a t -> int
val stats: 'a t -> statistics
+ val to_seq : 'a t -> (key * 'a) Seq.t
+ val to_seq_keys : _ t -> key Seq.t
+ val to_seq_values : 'a t -> 'a Seq.t
+ val add_seq : 'a t -> (key * 'a) Seq.t -> unit
+ val replace_seq : 'a t -> (key * 'a) Seq.t -> unit
+ val of_seq : (key * 'a) Seq.t -> 'a t
end
module type SeededS =
sig
'a t -> init:'b -> 'b
val length : 'a t -> int
val stats: 'a t -> statistics
+ val to_seq : 'a t -> (key * 'a) Seq.t
+ val to_seq_keys : _ t -> key Seq.t
+ val to_seq_values : 'a t -> 'a Seq.t
+ val add_seq : 'a t -> (key * 'a) Seq.t -> unit
+ val replace_seq : 'a t -> (key * 'a) Seq.t -> unit
+ val of_seq : (key * 'a) Seq.t -> 'a t
end
- module Make : functor (H : HashedType) -> S with type key = H.t
- module MakeSeeded (H : SeededHashedType) : SeededS with type key = H.t
+ module Make : functor (H : HashedType) -> S
+ with type key = H.t
+ and type 'a t = 'a Hashtbl.Make(H).t
+ module MakeSeeded (H : SeededHashedType) : SeededS
+ with type key = H.t
+ and type 'a t = 'a Hashtbl.MakeSeeded(H).t
val hash : 'a -> int
val seeded_hash : int -> 'a -> int
val hash_param : int -> int -> 'a -> int
val find_last_opt : f:(key -> bool) -> 'a t -> (key * 'a) option
val map : f:('a -> 'b) -> 'a t -> 'b t
val mapi : f:(key -> 'a -> 'b) -> 'a t -> 'b t
+ val to_seq : 'a t -> (key * 'a) Seq.t
+ val to_seq_from : key -> 'a t -> (key * 'a) Seq.t
+ val add_seq : (key * 'a) Seq.t -> 'a t -> 'a t
+ val of_seq : (key * 'a) Seq.t -> 'a t
end
- module Make : functor (Ord : OrderedType) -> S with type key = Ord.t
+ module Make : functor (Ord : OrderedType) -> S
+ with type key = Ord.t
+ and type 'a t = 'a Map.Make(Ord).t
end
module Set : sig
val find_last: f:(elt -> bool) -> t -> elt
val find_last_opt: f:(elt -> bool) -> t -> elt option
val of_list: elt list -> t
+ val to_seq_from : elt -> t -> elt Seq.t
+ val to_seq : t -> elt Seq.t
+ val add_seq : elt Seq.t -> t -> t
+ val of_seq : elt Seq.t -> t
end
- module Make : functor (Ord : OrderedType) -> S with type elt = Ord.t
+ module Make : functor (Ord : OrderedType) -> S
+ with type elt = Ord.t
+ and type t = Set.Make(Ord).t
end
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(* type 'a option = None | Some of 'a *)
-
-(* Exceptions *)
-
-external register_named_value : string -> 'a -> unit
- = "caml_register_named_value"
-
-let () =
- (* for asmrun/fail.c *)
- register_named_value "Pervasives.array_bound_error"
- (Invalid_argument "index out of bounds")
-
-
-external raise : exn -> 'a = "%raise"
-external raise_notrace : exn -> 'a = "%raise_notrace"
-
-let failwith s = raise(Failure s)
-let invalid_arg s = raise(Invalid_argument s)
-
-exception Exit
-
-(* Composition operators *)
-
-external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
-external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
-
-(* Debugging *)
-
-external __LOC__ : string = "%loc_LOC"
-external __FILE__ : string = "%loc_FILE"
-external __LINE__ : int = "%loc_LINE"
-external __MODULE__ : string = "%loc_MODULE"
-external __POS__ : string * int * int * int = "%loc_POS"
-
-external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
-external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
-external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
-
-(* Comparisons *)
-
-external ( = ) : 'a -> 'a -> bool = "%equal"
-external ( <> ) : 'a -> 'a -> bool = "%notequal"
-external ( < ) : 'a -> 'a -> bool = "%lessthan"
-external ( > ) : 'a -> 'a -> bool = "%greaterthan"
-external ( <= ) : 'a -> 'a -> bool = "%lessequal"
-external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
-external compare : 'a -> 'a -> int = "%compare"
-
-let min x y = if x <= y then x else y
-let max x y = if x >= y then x else y
-
-external ( == ) : 'a -> 'a -> bool = "%eq"
-external ( != ) : 'a -> 'a -> bool = "%noteq"
-
-(* Boolean operations *)
-
-external not : bool -> bool = "%boolnot"
-external ( & ) : bool -> bool -> bool = "%sequand"
-external ( && ) : bool -> bool -> bool = "%sequand"
-external ( or ) : bool -> bool -> bool = "%sequor"
-external ( || ) : bool -> bool -> bool = "%sequor"
-
-(* Integer operations *)
-
-external ( ~- ) : int -> int = "%negint"
-external ( ~+ ) : int -> int = "%identity"
-external succ : int -> int = "%succint"
-external pred : int -> int = "%predint"
-external ( + ) : int -> int -> int = "%addint"
-external ( - ) : int -> int -> int = "%subint"
-external ( * ) : int -> int -> int = "%mulint"
-external ( / ) : int -> int -> int = "%divint"
-external ( mod ) : int -> int -> int = "%modint"
-
-let abs x = if x >= 0 then x else -x
-
-external ( land ) : int -> int -> int = "%andint"
-external ( lor ) : int -> int -> int = "%orint"
-external ( lxor ) : int -> int -> int = "%xorint"
-
-let lnot x = x lxor (-1)
-
-external ( lsl ) : int -> int -> int = "%lslint"
-external ( lsr ) : int -> int -> int = "%lsrint"
-external ( asr ) : int -> int -> int = "%asrint"
-
-let max_int = (-1) lsr 1
-let min_int = max_int + 1
-
-(* Floating-point operations *)
-
-external ( ~-. ) : float -> float = "%negfloat"
-external ( ~+. ) : float -> float = "%identity"
-external ( +. ) : float -> float -> float = "%addfloat"
-external ( -. ) : float -> float -> float = "%subfloat"
-external ( *. ) : float -> float -> float = "%mulfloat"
-external ( /. ) : float -> float -> float = "%divfloat"
-external ( ** ) : float -> float -> float = "caml_power_float" "pow"
- [@@unboxed] [@@noalloc]
-external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc]
-external expm1 : float -> float = "caml_expm1_float" "caml_expm1"
- [@@unboxed] [@@noalloc]
-external acos : float -> float = "caml_acos_float" "acos"
- [@@unboxed] [@@noalloc]
-external asin : float -> float = "caml_asin_float" "asin"
- [@@unboxed] [@@noalloc]
-external atan : float -> float = "caml_atan_float" "atan"
- [@@unboxed] [@@noalloc]
-external atan2 : float -> float -> float = "caml_atan2_float" "atan2"
- [@@unboxed] [@@noalloc]
-external hypot : float -> float -> float
- = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc]
-external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc]
-external cosh : float -> float = "caml_cosh_float" "cosh"
- [@@unboxed] [@@noalloc]
-external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc]
-external log10 : float -> float = "caml_log10_float" "log10"
- [@@unboxed] [@@noalloc]
-external log1p : float -> float = "caml_log1p_float" "caml_log1p"
- [@@unboxed] [@@noalloc]
-external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc]
-external sinh : float -> float = "caml_sinh_float" "sinh"
- [@@unboxed] [@@noalloc]
-external sqrt : float -> float = "caml_sqrt_float" "sqrt"
- [@@unboxed] [@@noalloc]
-external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc]
-external tanh : float -> float = "caml_tanh_float" "tanh"
- [@@unboxed] [@@noalloc]
-external ceil : float -> float = "caml_ceil_float" "ceil"
- [@@unboxed] [@@noalloc]
-external floor : float -> float = "caml_floor_float" "floor"
- [@@unboxed] [@@noalloc]
-external abs_float : float -> float = "%absfloat"
-external copysign : float -> float -> float
- = "caml_copysign_float" "caml_copysign"
- [@@unboxed] [@@noalloc]
-external mod_float : float -> float -> float = "caml_fmod_float" "fmod"
- [@@unboxed] [@@noalloc]
-external frexp : float -> float * int = "caml_frexp_float"
-external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
- "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc]
-external modf : float -> float * float = "caml_modf_float"
-external float : int -> float = "%floatofint"
-external float_of_int : int -> float = "%floatofint"
-external truncate : float -> int = "%intoffloat"
-external int_of_float : float -> int = "%intoffloat"
-external float_of_bits : int64 -> float
- = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed"
- [@@unboxed] [@@noalloc]
-let infinity =
- float_of_bits 0x7F_F0_00_00_00_00_00_00L
-let neg_infinity =
- float_of_bits 0xFF_F0_00_00_00_00_00_00L
-let nan =
- float_of_bits 0x7F_F0_00_00_00_00_00_01L
-let max_float =
- float_of_bits 0x7F_EF_FF_FF_FF_FF_FF_FFL
-let min_float =
- float_of_bits 0x00_10_00_00_00_00_00_00L
-let epsilon_float =
- float_of_bits 0x3C_B0_00_00_00_00_00_00L
-
-type fpclass =
- FP_normal
- | FP_subnormal
- | FP_zero
- | FP_infinite
- | FP_nan
-external classify_float : (float [@unboxed]) -> fpclass =
- "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
-
-(* String and byte sequence operations -- more in modules String and Bytes *)
-
-external string_length : string -> int = "%string_length"
-external bytes_length : bytes -> int = "%bytes_length"
-external bytes_create : int -> bytes = "caml_create_bytes"
-external string_blit : string -> int -> bytes -> int -> int -> unit
- = "caml_blit_string" [@@noalloc]
-external bytes_blit : bytes -> int -> bytes -> int -> int -> unit
- = "caml_blit_bytes" [@@noalloc]
-external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
-
-let ( ^ ) s1 s2 =
- let l1 = string_length s1 and l2 = string_length s2 in
- let s = bytes_create (l1 + l2) in
- string_blit s1 0 s 0 l1;
- string_blit s2 0 s l1 l2;
- bytes_unsafe_to_string s
-
-(* Character operations -- more in module Char *)
-
-external int_of_char : char -> int = "%identity"
-external unsafe_char_of_int : int -> char = "%identity"
-let char_of_int n =
- if n < 0 || n > 255 then invalid_arg "char_of_int" else unsafe_char_of_int n
-
-(* Unit operations *)
-
-external ignore : 'a -> unit = "%ignore"
-
-(* Pair operations *)
-
-external fst : 'a * 'b -> 'a = "%field0"
-external snd : 'a * 'b -> 'b = "%field1"
-
-(* References *)
-
-type 'a ref = { mutable contents : 'a }
-external ref : 'a -> 'a ref = "%makemutable"
-external ( ! ) : 'a ref -> 'a = "%field0"
-external ( := ) : 'a ref -> 'a -> unit = "%setfield0"
-external incr : int ref -> unit = "%incr"
-external decr : int ref -> unit = "%decr"
-
-(* Result type *)
-
-type ('a,'b) result = Ok of 'a | Error of 'b
-
-(* String conversion functions *)
-
-external format_int : string -> int -> string = "caml_format_int"
-external format_float : string -> float -> string = "caml_format_float"
-
-let string_of_bool b =
- if b then "true" else "false"
-let bool_of_string = function
- | "true" -> true
- | "false" -> false
- | _ -> invalid_arg "bool_of_string"
-
-let bool_of_string_opt = function
- | "true" -> Some true
- | "false" -> Some false
- | _ -> None
-
-let string_of_int n =
- format_int "%d" n
-
-external int_of_string : string -> int = "caml_int_of_string"
-
-let int_of_string_opt s =
- (* TODO: provide this directly as a non-raising primitive. *)
- try Some (int_of_string s)
- with Failure _ -> None
-
-external string_get : string -> int -> char = "%string_safe_get"
-
-let valid_float_lexem s =
- let l = string_length s in
- let rec loop i =
- if i >= l then s ^ "." else
- match string_get s i with
- | '0' .. '9' | '-' -> loop (i + 1)
- | _ -> s
- in
- loop 0
-
-let string_of_float f = valid_float_lexem (format_float "%.12g" f)
-
-external float_of_string : string -> float = "caml_float_of_string"
-
-let float_of_string_opt s =
- (* TODO: provide this directly as a non-raising primitive. *)
- try Some (float_of_string s)
- with Failure _ -> None
-
-(* List operations -- more in module List *)
-
-let rec ( @ ) l1 l2 =
- match l1 with
- [] -> l2
- | hd :: tl -> hd :: (tl @ l2)
-
-(* I/O operations *)
-
-type in_channel
-type out_channel
-
-external open_descriptor_out : int -> out_channel
- = "caml_ml_open_descriptor_out"
-external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in"
-
-let stdin = open_descriptor_in 0
-let stdout = open_descriptor_out 1
-let stderr = open_descriptor_out 2
-
-(* General output functions *)
-
-type open_flag =
- Open_rdonly | Open_wronly | Open_append
- | Open_creat | Open_trunc | Open_excl
- | Open_binary | Open_text | Open_nonblock
-
-external open_desc : string -> open_flag list -> int -> int = "caml_sys_open"
-
-external set_out_channel_name: out_channel -> string -> unit =
- "caml_ml_set_channel_name"
-
-let open_out_gen mode perm name =
- let c = open_descriptor_out(open_desc name mode perm) in
- set_out_channel_name c name;
- c
-
-let open_out name =
- open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name
-
-let open_out_bin name =
- open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name
-
-external flush : out_channel -> unit = "caml_ml_flush"
-
-external out_channels_list : unit -> out_channel list
- = "caml_ml_out_channels_list"
-
-let flush_all () =
- let rec iter = function
- [] -> ()
- | a::l ->
- begin try
- flush a
- with Sys_error _ ->
- () (* ignore channels closed during a preceding flush. *)
- end;
- iter l
- in iter (out_channels_list ())
-
-external unsafe_output : out_channel -> bytes -> int -> int -> unit
- = "caml_ml_output_bytes"
-external unsafe_output_string : out_channel -> string -> int -> int -> unit
- = "caml_ml_output"
-
-external output_char : out_channel -> char -> unit = "caml_ml_output_char"
-
-let output_bytes oc s =
- unsafe_output oc s 0 (bytes_length s)
-
-let output_string oc s =
- unsafe_output_string oc s 0 (string_length s)
-
-let output oc s ofs len =
- if ofs < 0 || len < 0 || ofs > bytes_length s - len
- then invalid_arg "output"
- else unsafe_output oc s ofs len
-
-let output_substring oc s ofs len =
- if ofs < 0 || len < 0 || ofs > string_length s - len
- then invalid_arg "output_substring"
- else unsafe_output_string oc s ofs len
-
-external output_byte : out_channel -> int -> unit = "caml_ml_output_char"
-external output_binary_int : out_channel -> int -> unit = "caml_ml_output_int"
-
-external marshal_to_channel : out_channel -> 'a -> unit list -> unit
- = "caml_output_value"
-let output_value chan v = marshal_to_channel chan v []
-
-external seek_out : out_channel -> int -> unit = "caml_ml_seek_out"
-external pos_out : out_channel -> int = "caml_ml_pos_out"
-external out_channel_length : out_channel -> int = "caml_ml_channel_size"
-external close_out_channel : out_channel -> unit = "caml_ml_close_channel"
-let close_out oc = flush oc; close_out_channel oc
-let close_out_noerr oc =
- (try flush oc with _ -> ());
- (try close_out_channel oc with _ -> ())
-external set_binary_mode_out : out_channel -> bool -> unit
- = "caml_ml_set_binary_mode"
-
-(* General input functions *)
-
-external set_in_channel_name: in_channel -> string -> unit =
- "caml_ml_set_channel_name"
-
-let open_in_gen mode perm name =
- let c = open_descriptor_in(open_desc name mode perm) in
- set_in_channel_name c name;
- c
-
-let open_in name =
- open_in_gen [Open_rdonly; Open_text] 0 name
-
-let open_in_bin name =
- open_in_gen [Open_rdonly; Open_binary] 0 name
-
-external input_char : in_channel -> char = "caml_ml_input_char"
-
-external unsafe_input : in_channel -> bytes -> int -> int -> int
- = "caml_ml_input"
-
-let input ic s ofs len =
- if ofs < 0 || len < 0 || ofs > bytes_length s - len
- then invalid_arg "input"
- else unsafe_input ic s ofs len
-
-let rec unsafe_really_input ic s ofs len =
- if len <= 0 then () else begin
- let r = unsafe_input ic s ofs len in
- if r = 0
- then raise End_of_file
- else unsafe_really_input ic s (ofs + r) (len - r)
- end
-
-let really_input ic s ofs len =
- if ofs < 0 || len < 0 || ofs > bytes_length s - len
- then invalid_arg "really_input"
- else unsafe_really_input ic s ofs len
-
-let really_input_string ic len =
- let s = bytes_create len in
- really_input ic s 0 len;
- bytes_unsafe_to_string s
-
-external input_scan_line : in_channel -> int = "caml_ml_input_scan_line"
-
-let input_line chan =
- let rec build_result buf pos = function
- [] -> buf
- | hd :: tl ->
- let len = bytes_length hd in
- bytes_blit hd 0 buf (pos - len) len;
- build_result buf (pos - len) tl in
- let rec scan accu len =
- let n = input_scan_line chan in
- if n = 0 then begin (* n = 0: we are at EOF *)
- match accu with
- [] -> raise End_of_file
- | _ -> build_result (bytes_create len) len accu
- end else if n > 0 then begin (* n > 0: newline found in buffer *)
- let res = bytes_create (n - 1) in
- ignore (unsafe_input chan res 0 (n - 1));
- ignore (input_char chan); (* skip the newline *)
- match accu with
- [] -> res
- | _ -> let len = len + n - 1 in
- build_result (bytes_create len) len (res :: accu)
- end else begin (* n < 0: newline not found *)
- let beg = bytes_create (-n) in
- ignore(unsafe_input chan beg 0 (-n));
- scan (beg :: accu) (len - n)
- end
- in bytes_unsafe_to_string (scan [] 0)
-
-external input_byte : in_channel -> int = "caml_ml_input_char"
-external input_binary_int : in_channel -> int = "caml_ml_input_int"
-external input_value : in_channel -> 'a = "caml_input_value"
-external seek_in : in_channel -> int -> unit = "caml_ml_seek_in"
-external pos_in : in_channel -> int = "caml_ml_pos_in"
-external in_channel_length : in_channel -> int = "caml_ml_channel_size"
-external close_in : in_channel -> unit = "caml_ml_close_channel"
-let close_in_noerr ic = (try close_in ic with _ -> ())
-external set_binary_mode_in : in_channel -> bool -> unit
- = "caml_ml_set_binary_mode"
-
-(* Output functions on standard output *)
-
-let print_char c = output_char stdout c
-let print_string s = output_string stdout s
-let print_bytes s = output_bytes stdout s
-let print_int i = output_string stdout (string_of_int i)
-let print_float f = output_string stdout (string_of_float f)
-let print_endline s =
- output_string stdout s; output_char stdout '\n'; flush stdout
-let print_newline () = output_char stdout '\n'; flush stdout
-
-(* Output functions on standard error *)
-
-let prerr_char c = output_char stderr c
-let prerr_string s = output_string stderr s
-let prerr_bytes s = output_bytes stderr s
-let prerr_int i = output_string stderr (string_of_int i)
-let prerr_float f = output_string stderr (string_of_float f)
-let prerr_endline s =
- output_string stderr s; output_char stderr '\n'; flush stderr
-let prerr_newline () = output_char stderr '\n'; flush stderr
-
-(* Input functions on standard input *)
-
-let read_line () = flush stdout; input_line stdin
-let read_int () = int_of_string(read_line())
-let read_int_opt () = int_of_string_opt(read_line())
-let read_float () = float_of_string(read_line())
-let read_float_opt () = float_of_string_opt(read_line())
-
-(* Operations on large files *)
-
-module LargeFile =
- struct
- external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64"
- external pos_out : out_channel -> int64 = "caml_ml_pos_out_64"
- external out_channel_length : out_channel -> int64
- = "caml_ml_channel_size_64"
- external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64"
- external pos_in : in_channel -> int64 = "caml_ml_pos_in_64"
- external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64"
- end
-
-(* Formats *)
-
-type ('a, 'b, 'c, 'd, 'e, 'f) format6
- = ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
- = Format of ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt
- * string
-
-type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
-
-type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
-
-let string_of_format (Format (_fmt, str)) = str
-
-external format_of_string :
- ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
- ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
-
-let ( ^^ ) (Format (fmt1, str1)) (Format (fmt2, str2)) =
- Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2,
- str1 ^ "%," ^ str2)
-
-(* Miscellaneous *)
-
-external sys_exit : int -> 'a = "caml_sys_exit"
-
-let exit_function = ref flush_all
-
-let at_exit f =
- let g = !exit_function in
- exit_function := (fun () -> f(); g())
-
-let do_at_exit () = (!exit_function) ()
-
-let exit retcode =
- do_at_exit ();
- sys_exit retcode
-
-let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(** The initially opened module.
-
- This module provides the basic operations over the built-in types
- (numbers, booleans, byte sequences, strings, exceptions, references,
- lists, arrays, input-output channels, ...).
-
- This module is automatically opened at the beginning of each compilation.
- All components of this module can therefore be referred by their short
- name, without prefixing them by [Pervasives].
-*)
-
-
-(** {1 Exceptions} *)
-
-external raise : exn -> 'a = "%raise"
-(** Raise the given exception value *)
-
-external raise_notrace : exn -> 'a = "%raise_notrace"
-(** A faster version [raise] which does not record the backtrace.
- @since 4.02.0
-*)
-
-val invalid_arg : string -> 'a
-(** Raise exception [Invalid_argument] with the given string. *)
-
-val failwith : string -> 'a
-(** Raise exception [Failure] with the given string. *)
-
-exception Exit
-(** The [Exit] exception is not raised by any library function. It is
- provided for use in your programs. *)
-
-
-(** {1 Comparisons} *)
-
-external ( = ) : 'a -> 'a -> bool = "%equal"
-(** [e1 = e2] tests for structural equality of [e1] and [e2].
- Mutable structures (e.g. references and arrays) are equal
- if and only if their current contents are structurally equal,
- even if the two mutable objects are not the same physical object.
- Equality between functional values raises [Invalid_argument].
- Equality between cyclic data structures may not terminate.
- Left-associative operator at precedence level 4/11. *)
-
-external ( <> ) : 'a -> 'a -> bool = "%notequal"
-(** Negation of {!Pervasives.( = )}.
- Left-associative operator at precedence level 4/11. *)
-
-external ( < ) : 'a -> 'a -> bool = "%lessthan"
-(** See {!Pervasives.( >= )}.
- Left-associative operator at precedence level 4/11. *)
-
-external ( > ) : 'a -> 'a -> bool = "%greaterthan"
-(** See {!Pervasives.( >= )}.
- Left-associative operator at precedence level 4/11. *)
-
-external ( <= ) : 'a -> 'a -> bool = "%lessequal"
-(** See {!Pervasives.( >= )}.
- Left-associative operator at precedence level 4/11. *)
-
-external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
-(** Structural ordering functions. These functions coincide with
- the usual orderings over integers, characters, strings, byte sequences
- and floating-point numbers, and extend them to a
- total ordering over all types.
- The ordering is compatible with [( = )]. As in the case
- of [( = )], mutable structures are compared by contents.
- Comparison between functional values raises [Invalid_argument].
- Comparison between cyclic structures may not terminate.
- Left-associative operator at precedence level 4/11. *)
-
-external compare : 'a -> 'a -> int = "%compare"
-(** [compare x y] returns [0] if [x] is equal to [y],
- a negative integer if [x] is less than [y], and a positive integer
- if [x] is greater than [y]. The ordering implemented by [compare]
- is compatible with the comparison predicates [=], [<] and [>]
- defined above, with one difference on the treatment of the float value
- {!Pervasives.nan}. Namely, the comparison predicates treat [nan]
- as different from any other float value, including itself;
- while [compare] treats [nan] as equal to itself and less than any
- other float value. This treatment of [nan] ensures that [compare]
- defines a total ordering relation.
-
- [compare] applied to functional values may raise [Invalid_argument].
- [compare] applied to cyclic structures may not terminate.
-
- The [compare] function can be used as the comparison function
- required by the {!Set.Make} and {!Map.Make} functors, as well as
- the {!List.sort} and {!Array.sort} functions. *)
-
-val min : 'a -> 'a -> 'a
-(** Return the smaller of the two arguments.
- The result is unspecified if one of the arguments contains
- the float value [nan]. *)
-
-val max : 'a -> 'a -> 'a
-(** Return the greater of the two arguments.
- The result is unspecified if one of the arguments contains
- the float value [nan]. *)
-
-external ( == ) : 'a -> 'a -> bool = "%eq"
-(** [e1 == e2] tests for physical equality of [e1] and [e2].
- On mutable types such as references, arrays, byte sequences, records with
- mutable fields and objects with mutable instance variables,
- [e1 == e2] is true if and only if physical modification of [e1]
- also affects [e2].
- On non-mutable types, the behavior of [( == )] is
- implementation-dependent; however, it is guaranteed that
- [e1 == e2] implies [compare e1 e2 = 0].
- Left-associative operator at precedence level 4/11. *)
-
-external ( != ) : 'a -> 'a -> bool = "%noteq"
-(** Negation of {!Pervasives.( == )}.
- Left-associative operator at precedence level 4/11. *)
-
-
-(** {1 Boolean operations} *)
-
-external not : bool -> bool = "%boolnot"
-(** The boolean negation. *)
-
-external ( && ) : bool -> bool -> bool = "%sequand"
-(** The boolean 'and'. Evaluation is sequential, left-to-right:
- in [e1 && e2], [e1] is evaluated first, and if it returns [false],
- [e2] is not evaluated at all.
- Right-associative operator at precedence level 3/11. *)
-
-external ( & ) : bool -> bool -> bool = "%sequand"
- [@@ocaml.deprecated "Use (&&) instead."]
-(** @deprecated {!Pervasives.( && )} should be used instead.
- Right-associative operator at precedence level 3/11. *)
-
-external ( || ) : bool -> bool -> bool = "%sequor"
-(** The boolean 'or'. Evaluation is sequential, left-to-right:
- in [e1 || e2], [e1] is evaluated first, and if it returns [true],
- [e2] is not evaluated at all.
- Right-associative operator at precedence level 2/11.
-*)
-
-external ( or ) : bool -> bool -> bool = "%sequor"
- [@@ocaml.deprecated "Use (||) instead."]
-(** @deprecated {!Pervasives.( || )} should be used instead.
- Right-associative operator at precedence level 2/11. *)
-
-(** {1 Debugging} *)
-
-external __LOC__ : string = "%loc_LOC"
-(** [__LOC__] returns the location at which this expression appears in
- the file currently being parsed by the compiler, with the standard
- error format of OCaml: "File %S, line %d, characters %d-%d".
- @since 4.02.0
-*)
-
-external __FILE__ : string = "%loc_FILE"
-(** [__FILE__] returns the name of the file currently being
- parsed by the compiler.
- @since 4.02.0
-*)
-
-external __LINE__ : int = "%loc_LINE"
-(** [__LINE__] returns the line number at which this expression
- appears in the file currently being parsed by the compiler.
- @since 4.02.0
-*)
-
-external __MODULE__ : string = "%loc_MODULE"
-(** [__MODULE__] returns the module name of the file being
- parsed by the compiler.
- @since 4.02.0
-*)
-
-external __POS__ : string * int * int * int = "%loc_POS"
-(** [__POS__] returns a tuple [(file,lnum,cnum,enum)], corresponding
- to the location at which this expression appears in the file
- currently being parsed by the compiler. [file] is the current
- filename, [lnum] the line number, [cnum] the character position in
- the line and [enum] the last character position in the line.
- @since 4.02.0
- *)
-
-external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
-(** [__LOC_OF__ expr] returns a pair [(loc, expr)] where [loc] is the
- location of [expr] in the file currently being parsed by the
- compiler, with the standard error format of OCaml: "File %S, line
- %d, characters %d-%d".
- @since 4.02.0
-*)
-
-external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
-(** [__LINE__ expr] returns a pair [(line, expr)], where [line] is the
- line number at which the expression [expr] appears in the file
- currently being parsed by the compiler.
- @since 4.02.0
- *)
-
-external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
-(** [__POS_OF__ expr] returns a pair [(loc,expr)], where [loc] is a
- tuple [(file,lnum,cnum,enum)] corresponding to the location at
- which the expression [expr] appears in the file currently being
- parsed by the compiler. [file] is the current filename, [lnum] the
- line number, [cnum] the character position in the line and [enum]
- the last character position in the line.
- @since 4.02.0
- *)
-
-(** {1 Composition operators} *)
-
-external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
-(** Reverse-application operator: [x |> f |> g] is exactly equivalent
- to [g (f (x))].
- Left-associative operator at precedence level 4/11.
- @since 4.01
- *)
-
-external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
-(** Application operator: [g @@ f @@ x] is exactly equivalent to
- [g (f (x))].
- Right-associative operator at precedence level 5/11.
- @since 4.01
-*)
-
-(** {1 Integer arithmetic} *)
-
-(** Integers are 31 bits wide (or 63 bits on 64-bit processors).
- All operations are taken modulo 2{^31} (or 2{^63}).
- They do not fail on overflow. *)
-
-external ( ~- ) : int -> int = "%negint"
-(** Unary negation. You can also write [- e] instead of [~- e].
- Unary operator at precedence level 9/11 for [- e]
- and 11/11 for [~- e]. *)
-
-external ( ~+ ) : int -> int = "%identity"
-(** Unary addition. You can also write [+ e] instead of [~+ e].
- Unary operator at precedence level 9/11 for [+ e]
- and 11/11 for [~+ e].
- @since 3.12.0
-*)
-
-external succ : int -> int = "%succint"
-(** [succ x] is [x + 1]. *)
-
-external pred : int -> int = "%predint"
-(** [pred x] is [x - 1]. *)
-
-external ( + ) : int -> int -> int = "%addint"
-(** Integer addition.
- Left-associative operator at precedence level 6/11. *)
-
-external ( - ) : int -> int -> int = "%subint"
-(** Integer subtraction.
- Left-associative operator at precedence level 6/11. *)
-
-external ( * ) : int -> int -> int = "%mulint"
-(** Integer multiplication.
- Left-associative operator at precedence level 7/11. *)
-
-external ( / ) : int -> int -> int = "%divint"
-(** Integer division.
- Raise [Division_by_zero] if the second argument is 0.
- Integer division rounds the real quotient of its arguments towards zero.
- More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer
- less than or equal to the real quotient of [x] by [y]. Moreover,
- [(- x) / y = x / (- y) = - (x / y)].
- Left-associative operator at precedence level 7/11. *)
-
-external ( mod ) : int -> int -> int = "%modint"
-(** Integer remainder. If [y] is not zero, the result
- of [x mod y] satisfies the following properties:
- [x = (x / y) * y + x mod y] and
- [abs(x mod y) <= abs(y) - 1].
- If [y = 0], [x mod y] raises [Division_by_zero].
- Note that [x mod y] is negative only if [x < 0].
- Raise [Division_by_zero] if [y] is zero.
- Left-associative operator at precedence level 7/11. *)
-
-val abs : int -> int
-(** Return the absolute value of the argument. Note that this may be
- negative if the argument is [min_int]. *)
-
-val max_int : int
-(** The greatest representable integer. *)
-
-val min_int : int
-(** The smallest representable integer. *)
-
-
-(** {2 Bitwise operations} *)
-
-external ( land ) : int -> int -> int = "%andint"
-(** Bitwise logical and.
- Left-associative operator at precedence level 7/11. *)
-
-external ( lor ) : int -> int -> int = "%orint"
-(** Bitwise logical or.
- Left-associative operator at precedence level 7/11. *)
-
-external ( lxor ) : int -> int -> int = "%xorint"
-(** Bitwise logical exclusive or.
- Left-associative operator at precedence level 7/11. *)
-
-val lnot : int -> int
-(** Bitwise logical negation. *)
-
-external ( lsl ) : int -> int -> int = "%lslint"
-(** [n lsl m] shifts [n] to the left by [m] bits.
- The result is unspecified if [m < 0] or [m >= bitsize],
- where [bitsize] is [32] on a 32-bit platform and
- [64] on a 64-bit platform.
- Right-associative operator at precedence level 8/11. *)
-
-external ( lsr ) : int -> int -> int = "%lsrint"
-(** [n lsr m] shifts [n] to the right by [m] bits.
- This is a logical shift: zeroes are inserted regardless of
- the sign of [n].
- The result is unspecified if [m < 0] or [m >= bitsize].
- Right-associative operator at precedence level 8/11. *)
-
-external ( asr ) : int -> int -> int = "%asrint"
-(** [n asr m] shifts [n] to the right by [m] bits.
- This is an arithmetic shift: the sign bit of [n] is replicated.
- The result is unspecified if [m < 0] or [m >= bitsize].
- Right-associative operator at precedence level 8/11. *)
-
-
-(** {1 Floating-point arithmetic}
-
- OCaml's floating-point numbers follow the
- IEEE 754 standard, using double precision (64 bits) numbers.
- Floating-point operations never raise an exception on overflow,
- underflow, division by zero, etc. Instead, special IEEE numbers
- are returned as appropriate, such as [infinity] for [1.0 /. 0.0],
- [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number')
- for [0.0 /. 0.0]. These special numbers then propagate through
- floating-point computations as expected: for instance,
- [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan]
- as argument returns [nan] as result.
-*)
-
-external ( ~-. ) : float -> float = "%negfloat"
-(** Unary negation. You can also write [-. e] instead of [~-. e].
- Unary operator at precedence level 9/11 for [-. e]
- and 11/11 for [~-. e]. *)
-
-external ( ~+. ) : float -> float = "%identity"
-(** Unary addition. You can also write [+. e] instead of [~+. e].
- Unary operator at precedence level 9/11 for [+. e]
- and 11/11 for [~+. e].
- @since 3.12.0
-*)
-
-external ( +. ) : float -> float -> float = "%addfloat"
-(** Floating-point addition.
- Left-associative operator at precedence level 6/11. *)
-
-external ( -. ) : float -> float -> float = "%subfloat"
-(** Floating-point subtraction.
- Left-associative operator at precedence level 6/11. *)
-
-external ( *. ) : float -> float -> float = "%mulfloat"
-(** Floating-point multiplication.
- Left-associative operator at precedence level 7/11. *)
-
-external ( /. ) : float -> float -> float = "%divfloat"
-(** Floating-point division.
- Left-associative operator at precedence level 7/11. *)
-
-external ( ** ) : float -> float -> float = "caml_power_float" "pow"
- [@@unboxed] [@@noalloc]
-(** Exponentiation.
- Right-associative operator at precedence level 8/11. *)
-
-external sqrt : float -> float = "caml_sqrt_float" "sqrt"
- [@@unboxed] [@@noalloc]
-(** Square root. *)
-
-external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc]
-(** Exponential. *)
-
-external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc]
-(** Natural logarithm. *)
-
-external log10 : float -> float = "caml_log10_float" "log10"
- [@@unboxed] [@@noalloc]
-(** Base 10 logarithm. *)
-
-external expm1 : float -> float = "caml_expm1_float" "caml_expm1"
- [@@unboxed] [@@noalloc]
-(** [expm1 x] computes [exp x -. 1.0], giving numerically-accurate results
- even if [x] is close to [0.0].
- @since 3.12.0
-*)
-
-external log1p : float -> float = "caml_log1p_float" "caml_log1p"
- [@@unboxed] [@@noalloc]
-(** [log1p x] computes [log(1.0 +. x)] (natural logarithm),
- giving numerically-accurate results even if [x] is close to [0.0].
- @since 3.12.0
-*)
-
-external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc]
-(** Cosine. Argument is in radians. *)
-
-external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc]
-(** Sine. Argument is in radians. *)
-
-external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc]
-(** Tangent. Argument is in radians. *)
-
-external acos : float -> float = "caml_acos_float" "acos"
- [@@unboxed] [@@noalloc]
-(** Arc cosine. The argument must fall within the range [[-1.0, 1.0]].
- Result is in radians and is between [0.0] and [pi]. *)
-
-external asin : float -> float = "caml_asin_float" "asin"
- [@@unboxed] [@@noalloc]
-(** Arc sine. The argument must fall within the range [[-1.0, 1.0]].
- Result is in radians and is between [-pi/2] and [pi/2]. *)
-
-external atan : float -> float = "caml_atan_float" "atan"
- [@@unboxed] [@@noalloc]
-(** Arc tangent.
- Result is in radians and is between [-pi/2] and [pi/2]. *)
-
-external atan2 : float -> float -> float = "caml_atan2_float" "atan2"
- [@@unboxed] [@@noalloc]
-(** [atan2 y x] returns the arc tangent of [y /. x]. The signs of [x]
- and [y] are used to determine the quadrant of the result.
- Result is in radians and is between [-pi] and [pi]. *)
-
-external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot"
- [@@unboxed] [@@noalloc]
-(** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length
- of the hypotenuse of a right-angled triangle with sides of length
- [x] and [y], or, equivalently, the distance of the point [(x,y)]
- to origin. If one of [x] or [y] is infinite, returns [infinity]
- even if the other is [nan].
- @since 4.00.0 *)
-
-external cosh : float -> float = "caml_cosh_float" "cosh"
- [@@unboxed] [@@noalloc]
-(** Hyperbolic cosine. Argument is in radians. *)
-
-external sinh : float -> float = "caml_sinh_float" "sinh"
- [@@unboxed] [@@noalloc]
-(** Hyperbolic sine. Argument is in radians. *)
-
-external tanh : float -> float = "caml_tanh_float" "tanh"
- [@@unboxed] [@@noalloc]
-(** Hyperbolic tangent. Argument is in radians. *)
-
-external ceil : float -> float = "caml_ceil_float" "ceil"
- [@@unboxed] [@@noalloc]
-(** Round above to an integer value.
- [ceil f] returns the least integer value greater than or equal to [f].
- The result is returned as a float. *)
-
-external floor : float -> float = "caml_floor_float" "floor"
- [@@unboxed] [@@noalloc]
-(** Round below to an integer value.
- [floor f] returns the greatest integer value less than or
- equal to [f].
- The result is returned as a float. *)
-
-external abs_float : float -> float = "%absfloat"
-(** [abs_float f] returns the absolute value of [f]. *)
-
-external copysign : float -> float -> float
- = "caml_copysign_float" "caml_copysign"
- [@@unboxed] [@@noalloc]
-(** [copysign x y] returns a float whose absolute value is that of [x]
- and whose sign is that of [y]. If [x] is [nan], returns [nan].
- If [y] is [nan], returns either [x] or [-. x], but it is not
- specified which.
- @since 4.00.0 *)
-
-external mod_float : float -> float -> float = "caml_fmod_float" "fmod"
- [@@unboxed] [@@noalloc]
-(** [mod_float a b] returns the remainder of [a] with respect to
- [b]. The returned value is [a -. n *. b], where [n]
- is the quotient [a /. b] rounded towards zero to an integer. *)
-
-external frexp : float -> float * int = "caml_frexp_float"
-(** [frexp f] returns the pair of the significant
- and the exponent of [f]. When [f] is zero, the
- significant [x] and the exponent [n] of [f] are equal to
- zero. When [f] is non-zero, they are defined by
- [f = x *. 2 ** n] and [0.5 <= x < 1.0]. *)
-
-
-external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
- "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc]
-(** [ldexp x n] returns [x *. 2 ** n]. *)
-
-external modf : float -> float * float = "caml_modf_float"
-(** [modf f] returns the pair of the fractional and integral
- part of [f]. *)
-
-external float : int -> float = "%floatofint"
-(** Same as {!Pervasives.float_of_int}. *)
-
-external float_of_int : int -> float = "%floatofint"
-(** Convert an integer to floating-point. *)
-
-external truncate : float -> int = "%intoffloat"
-(** Same as {!Pervasives.int_of_float}. *)
-
-external int_of_float : float -> int = "%intoffloat"
-(** Truncate the given floating-point number to an integer.
- The result is unspecified if the argument is [nan] or falls outside the
- range of representable integers. *)
-
-val infinity : float
-(** Positive infinity. *)
-
-val neg_infinity : float
-(** Negative infinity. *)
-
-val nan : float
-(** A special floating-point value denoting the result of an
- undefined operation such as [0.0 /. 0.0]. Stands for
- 'not a number'. Any floating-point operation with [nan] as
- argument returns [nan] as result. As for floating-point comparisons,
- [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true]
- if one or both of their arguments is [nan]. *)
-
-val max_float : float
-(** The largest positive finite value of type [float]. *)
-
-val min_float : float
-(** The smallest positive, non-zero, non-denormalized value of type [float]. *)
-
-val epsilon_float : float
-(** The difference between [1.0] and the smallest exactly representable
- floating-point number greater than [1.0]. *)
-
-type fpclass =
- FP_normal (** Normal number, none of the below *)
- | FP_subnormal (** Number very close to 0.0, has reduced precision *)
- | FP_zero (** Number is 0.0 or -0.0 *)
- | FP_infinite (** Number is positive or negative infinity *)
- | FP_nan (** Not a number: result of an undefined operation *)
-(** The five classes of floating-point numbers, as determined by
- the {!Pervasives.classify_float} function. *)
-
-external classify_float : (float [@unboxed]) -> fpclass =
- "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
-(** Return the class of the given floating-point number:
- normal, subnormal, zero, infinite, or not a number. *)
-
-
-(** {1 String operations}
-
- More string operations are provided in module {!String}.
-*)
-
-val ( ^ ) : string -> string -> string
-(** String concatenation.
- Right-associative operator at precedence level 5/11. *)
-
-
-(** {1 Character operations}
-
- More character operations are provided in module {!Char}.
-*)
-
-external int_of_char : char -> int = "%identity"
-(** Return the ASCII code of the argument. *)
-
-val char_of_int : int -> char
-(** Return the character with the given ASCII code.
- Raise [Invalid_argument "char_of_int"] if the argument is
- outside the range 0--255. *)
-
-
-(** {1 Unit operations} *)
-
-external ignore : 'a -> unit = "%ignore"
-(** Discard the value of its argument and return [()].
- For instance, [ignore(f x)] discards the result of
- the side-effecting function [f]. It is equivalent to
- [f x; ()], except that the latter may generate a
- compiler warning; writing [ignore(f x)] instead
- avoids the warning. *)
-
-
-(** {1 String conversion functions} *)
-
-val string_of_bool : bool -> string
-(** Return the string representation of a boolean. As the returned values
- may be shared, the user should not modify them directly.
-*)
-
-val bool_of_string : string -> bool
-(** Convert the given string to a boolean.
- Raise [Invalid_argument "bool_of_string"] if the string is not
- ["true"] or ["false"]. *)
-
-val bool_of_string_opt: string -> bool option
-(** Convert the given string to a boolean.
- Return [None] if the string is not
- ["true"] or ["false"].
- @since 4.05
-*)
-
-val string_of_int : int -> string
-(** Return the string representation of an integer, in decimal. *)
-
-external int_of_string : string -> int = "caml_int_of_string"
-(** Convert the given string to an integer.
- The string is read in decimal (by default, or if the string
- begins with [0u]), in hexadecimal (if it begins with [0x] or
- [0X]), in octal (if it begins with [0o] or [0O]), or in binary
- (if it begins with [0b] or [0B]).
-
- The [0u] prefix reads the input as an unsigned integer in the range
- [[0, 2*max_int+1]]. If the input exceeds {!max_int}
- it is converted to the signed integer
- [min_int + input - max_int - 1].
-
- The [_] (underscore) character can appear anywhere in the string
- and is ignored.
- Raise [Failure "int_of_string"] if the given string is not
- a valid representation of an integer, or if the integer represented
- exceeds the range of integers representable in type [int]. *)
-
-
-val int_of_string_opt: string -> int option
-(** Same as [int_of_string], but returns [None] instead of raising.
- @since 4.05
-*)
-
-val string_of_float : float -> string
-(** Return the string representation of a floating-point number. *)
-
-external float_of_string : string -> float = "caml_float_of_string"
-(** Convert the given string to a float. The string is read in decimal
- (by default) or in hexadecimal (marked by [0x] or [0X]).
- The format of decimal floating-point numbers is
- [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit.
- The format of hexadecimal floating-point numbers is
- [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an
- hexadecimal digit and [d] for a decimal digit.
- In both cases, at least one of the integer and fractional parts must be
- given; the exponent part is optional.
- The [_] (underscore) character can appear anywhere in the string
- and is ignored.
- Depending on the execution platforms, other representations of
- floating-point numbers can be accepted, but should not be relied upon.
- Raise [Failure "float_of_string"] if the given string is not a valid
- representation of a float. *)
-
-val float_of_string_opt: string -> float option
-(** Same as [float_of_string], but returns [None] instead of raising.
- @since 4.05
-*)
-
-(** {1 Pair operations} *)
-
-external fst : 'a * 'b -> 'a = "%field0"
-(** Return the first component of a pair. *)
-
-external snd : 'a * 'b -> 'b = "%field1"
-(** Return the second component of a pair. *)
-
-
-(** {1 List operations}
-
- More list operations are provided in module {!List}.
-*)
-
-val ( @ ) : 'a list -> 'a list -> 'a list
-(** List concatenation. Not tail-recursive (length of the first argument).
- Right-associative operator at precedence level 5/11. *)
-
-
-(** {1 Input/output}
- Note: all input/output functions can raise [Sys_error] when the system
- calls they invoke fail. *)
-
-type in_channel
-(** The type of input channel. *)
-
-type out_channel
-(** The type of output channel. *)
-
-val stdin : in_channel
-(** The standard input for the process. *)
-
-val stdout : out_channel
-(** The standard output for the process. *)
-
-val stderr : out_channel
-(** The standard error output for the process. *)
-
-
-(** {2 Output functions on standard output} *)
-
-val print_char : char -> unit
-(** Print a character on standard output. *)
-
-val print_string : string -> unit
-(** Print a string on standard output. *)
-
-val print_bytes : bytes -> unit
-(** Print a byte sequence on standard output.
- @since 4.02.0 *)
-
-val print_int : int -> unit
-(** Print an integer, in decimal, on standard output. *)
-
-val print_float : float -> unit
-(** Print a floating-point number, in decimal, on standard output. *)
-
-val print_endline : string -> unit
-(** Print a string, followed by a newline character, on
- standard output and flush standard output. *)
-
-val print_newline : unit -> unit
-(** Print a newline character on standard output, and flush
- standard output. This can be used to simulate line
- buffering of standard output. *)
-
-
-(** {2 Output functions on standard error} *)
-
-val prerr_char : char -> unit
-(** Print a character on standard error. *)
-
-val prerr_string : string -> unit
-(** Print a string on standard error. *)
-
-val prerr_bytes : bytes -> unit
-(** Print a byte sequence on standard error.
- @since 4.02.0 *)
-
-val prerr_int : int -> unit
-(** Print an integer, in decimal, on standard error. *)
-
-val prerr_float : float -> unit
-(** Print a floating-point number, in decimal, on standard error. *)
-
-val prerr_endline : string -> unit
-(** Print a string, followed by a newline character on standard
- error and flush standard error. *)
-
-val prerr_newline : unit -> unit
-(** Print a newline character on standard error, and flush
- standard error. *)
-
-
-(** {2 Input functions on standard input} *)
-
-val read_line : unit -> string
-(** Flush standard output, then read characters from standard input
- until a newline character is encountered. Return the string of
- all characters read, without the newline character at the end. *)
-
-val read_int : unit -> int
-(** Flush standard output, then read one line from standard input
- and convert it to an integer. Raise [Failure "int_of_string"]
- if the line read is not a valid representation of an integer. *)
-
-val read_int_opt: unit -> int option
-(** Same as [read_int_opt], but returns [None] instead of raising.
- @since 4.05
-*)
-
-val read_float : unit -> float
-(** Flush standard output, then read one line from standard input
- and convert it to a floating-point number.
- The result is unspecified if the line read is not a valid
- representation of a floating-point number. *)
-
-val read_float_opt: unit -> float option
-(** Flush standard output, then read one line from standard input
- and convert it to a floating-point number.
- Returns [None] if the line read is not a valid
- representation of a floating-point number.
- @since 4.05.0 *)
-
-
-(** {2 General output functions} *)
-
-type open_flag =
- Open_rdonly (** open for reading. *)
- | Open_wronly (** open for writing. *)
- | Open_append (** open for appending: always write at end of file. *)
- | Open_creat (** create the file if it does not exist. *)
- | Open_trunc (** empty the file if it already exists. *)
- | Open_excl (** fail if Open_creat and the file already exists. *)
- | Open_binary (** open in binary mode (no conversion). *)
- | Open_text (** open in text mode (may perform conversions). *)
- | Open_nonblock (** open in non-blocking mode. *)
-(** Opening modes for {!Pervasives.open_out_gen} and
- {!Pervasives.open_in_gen}. *)
-
-val open_out : string -> out_channel
-(** Open the named file for writing, and return a new output channel
- on that file, positioned at the beginning of the file. The
- file is truncated to zero length if it already exists. It
- is created if it does not already exists. *)
-
-val open_out_bin : string -> out_channel
-(** Same as {!Pervasives.open_out}, but the file is opened in binary mode,
- so that no translation takes place during writes. On operating
- systems that do not distinguish between text mode and binary
- mode, this function behaves like {!Pervasives.open_out}. *)
-
-val open_out_gen : open_flag list -> int -> string -> out_channel
-(** [open_out_gen mode perm filename] opens the named file for writing,
- as described above. The extra argument [mode]
- specifies the opening mode. The extra argument [perm] specifies
- the file permissions, in case the file must be created.
- {!Pervasives.open_out} and {!Pervasives.open_out_bin} are special
- cases of this function. *)
-
-val flush : out_channel -> unit
-(** Flush the buffer associated with the given output channel,
- performing all pending writes on that channel.
- Interactive programs must be careful about flushing standard
- output and standard error at the right time. *)
-
-val flush_all : unit -> unit
-(** Flush all open output channels; ignore errors. *)
-
-val output_char : out_channel -> char -> unit
-(** Write the character on the given output channel. *)
-
-val output_string : out_channel -> string -> unit
-(** Write the string on the given output channel. *)
-
-val output_bytes : out_channel -> bytes -> unit
-(** Write the byte sequence on the given output channel.
- @since 4.02.0 *)
-
-val output : out_channel -> bytes -> int -> int -> unit
-(** [output oc buf pos len] writes [len] characters from byte sequence [buf],
- starting at offset [pos], to the given output channel [oc].
- Raise [Invalid_argument "output"] if [pos] and [len] do not
- designate a valid range of [buf]. *)
-
-val output_substring : out_channel -> string -> int -> int -> unit
-(** Same as [output] but take a string as argument instead of
- a byte sequence.
- @since 4.02.0 *)
-
-val output_byte : out_channel -> int -> unit
-(** Write one 8-bit integer (as the single character with that code)
- on the given output channel. The given integer is taken modulo
- 256. *)
-
-val output_binary_int : out_channel -> int -> unit
-(** Write one integer in binary format (4 bytes, big-endian)
- on the given output channel.
- The given integer is taken modulo 2{^32}.
- The only reliable way to read it back is through the
- {!Pervasives.input_binary_int} function. The format is compatible across
- all machines for a given version of OCaml. *)
-
-val output_value : out_channel -> 'a -> unit
-(** Write the representation of a structured value of any type
- to a channel. Circularities and sharing inside the value
- are detected and preserved. The object can be read back,
- by the function {!Pervasives.input_value}. See the description of module
- {!Marshal} for more information. {!Pervasives.output_value} is equivalent
- to {!Marshal.to_channel} with an empty list of flags. *)
-
-val seek_out : out_channel -> int -> unit
-(** [seek_out chan pos] sets the current writing position to [pos]
- for channel [chan]. This works only for regular files. On
- files of other kinds (such as terminals, pipes and sockets),
- the behavior is unspecified. *)
-
-val pos_out : out_channel -> int
-(** Return the current writing position for the given channel. Does
- not work on channels opened with the [Open_append] flag (returns
- unspecified results). *)
-
-val out_channel_length : out_channel -> int
-(** Return the size (number of characters) of the regular file
- on which the given channel is opened. If the channel is opened
- on a file that is not a regular file, the result is meaningless. *)
-
-val close_out : out_channel -> unit
-(** Close the given channel, flushing all buffered write operations.
- Output functions raise a [Sys_error] exception when they are
- applied to a closed output channel, except [close_out] and [flush],
- which do nothing when applied to an already closed channel.
- Note that [close_out] may raise [Sys_error] if the operating
- system signals an error when flushing or closing. *)
-
-val close_out_noerr : out_channel -> unit
-(** Same as [close_out], but ignore all errors. *)
-
-val set_binary_mode_out : out_channel -> bool -> unit
-(** [set_binary_mode_out oc true] sets the channel [oc] to binary
- mode: no translations take place during output.
- [set_binary_mode_out oc false] sets the channel [oc] to text
- mode: depending on the operating system, some translations
- may take place during output. For instance, under Windows,
- end-of-lines will be translated from [\n] to [\r\n].
- This function has no effect under operating systems that
- do not distinguish between text mode and binary mode. *)
-
-
-(** {2 General input functions} *)
-
-val open_in : string -> in_channel
-(** Open the named file for reading, and return a new input channel
- on that file, positioned at the beginning of the file. *)
-
-val open_in_bin : string -> in_channel
-(** Same as {!Pervasives.open_in}, but the file is opened in binary mode,
- so that no translation takes place during reads. On operating
- systems that do not distinguish between text mode and binary
- mode, this function behaves like {!Pervasives.open_in}. *)
-
-val open_in_gen : open_flag list -> int -> string -> in_channel
-(** [open_in_gen mode perm filename] opens the named file for reading,
- as described above. The extra arguments
- [mode] and [perm] specify the opening mode and file permissions.
- {!Pervasives.open_in} and {!Pervasives.open_in_bin} are special
- cases of this function. *)
-
-val input_char : in_channel -> char
-(** Read one character from the given input channel.
- Raise [End_of_file] if there are no more characters to read. *)
-
-val input_line : in_channel -> string
-(** Read characters from the given input channel, until a
- newline character is encountered. Return the string of
- all characters read, without the newline character at the end.
- Raise [End_of_file] if the end of the file is reached
- at the beginning of line. *)
-
-val input : in_channel -> bytes -> int -> int -> int
-(** [input ic buf pos len] reads up to [len] characters from
- the given channel [ic], storing them in byte sequence [buf], starting at
- character number [pos].
- It returns the actual number of characters read, between 0 and
- [len] (inclusive).
- A return value of 0 means that the end of file was reached.
- A return value between 0 and [len] exclusive means that
- not all requested [len] characters were read, either because
- no more characters were available at that time, or because
- the implementation found it convenient to do a partial read;
- [input] must be called again to read the remaining characters,
- if desired. (See also {!Pervasives.really_input} for reading
- exactly [len] characters.)
- Exception [Invalid_argument "input"] is raised if [pos] and [len]
- do not designate a valid range of [buf]. *)
-
-val really_input : in_channel -> bytes -> int -> int -> unit
-(** [really_input ic buf pos len] reads [len] characters from channel [ic],
- storing them in byte sequence [buf], starting at character number [pos].
- Raise [End_of_file] if the end of file is reached before [len]
- characters have been read.
- Raise [Invalid_argument "really_input"] if
- [pos] and [len] do not designate a valid range of [buf]. *)
-
-val really_input_string : in_channel -> int -> string
-(** [really_input_string ic len] reads [len] characters from channel [ic]
- and returns them in a new string.
- Raise [End_of_file] if the end of file is reached before [len]
- characters have been read.
- @since 4.02.0 *)
-
-val input_byte : in_channel -> int
-(** Same as {!Pervasives.input_char}, but return the 8-bit integer representing
- the character.
- Raise [End_of_file] if an end of file was reached. *)
-
-val input_binary_int : in_channel -> int
-(** Read an integer encoded in binary format (4 bytes, big-endian)
- from the given input channel. See {!Pervasives.output_binary_int}.
- Raise [End_of_file] if an end of file was reached while reading the
- integer. *)
-
-val input_value : in_channel -> 'a
-(** Read the representation of a structured value, as produced
- by {!Pervasives.output_value}, and return the corresponding value.
- This function is identical to {!Marshal.from_channel};
- see the description of module {!Marshal} for more information,
- in particular concerning the lack of type safety. *)
-
-val seek_in : in_channel -> int -> unit
-(** [seek_in chan pos] sets the current reading position to [pos]
- for channel [chan]. This works only for regular files. On
- files of other kinds, the behavior is unspecified. *)
-
-val pos_in : in_channel -> int
-(** Return the current reading position for the given channel. *)
-
-val in_channel_length : in_channel -> int
-(** Return the size (number of characters) of the regular file
- on which the given channel is opened. If the channel is opened
- on a file that is not a regular file, the result is meaningless.
- The returned size does not take into account the end-of-line
- translations that can be performed when reading from a channel
- opened in text mode. *)
-
-val close_in : in_channel -> unit
-(** Close the given channel. Input functions raise a [Sys_error]
- exception when they are applied to a closed input channel,
- except [close_in], which does nothing when applied to an already
- closed channel. *)
-
-val close_in_noerr : in_channel -> unit
-(** Same as [close_in], but ignore all errors. *)
-
-val set_binary_mode_in : in_channel -> bool -> unit
-(** [set_binary_mode_in ic true] sets the channel [ic] to binary
- mode: no translations take place during input.
- [set_binary_mode_out ic false] sets the channel [ic] to text
- mode: depending on the operating system, some translations
- may take place during input. For instance, under Windows,
- end-of-lines will be translated from [\r\n] to [\n].
- This function has no effect under operating systems that
- do not distinguish between text mode and binary mode. *)
-
-
-(** {2 Operations on large files} *)
-
-module LargeFile :
- sig
- val seek_out : out_channel -> int64 -> unit
- val pos_out : out_channel -> int64
- val out_channel_length : out_channel -> int64
- val seek_in : in_channel -> int64 -> unit
- val pos_in : in_channel -> int64
- val in_channel_length : in_channel -> int64
- end
-(** Operations on large files.
- This sub-module provides 64-bit variants of the channel functions
- that manipulate file positions and file sizes. By representing
- positions and sizes by 64-bit integers (type [int64]) instead of
- regular integers (type [int]), these alternate functions allow
- operating on files whose sizes are greater than [max_int]. *)
-
-
-(** {1 References} *)
-
-type 'a ref = { mutable contents : 'a }
-(** The type of references (mutable indirection cells) containing
- a value of type ['a]. *)
-
-external ref : 'a -> 'a ref = "%makemutable"
-(** Return a fresh reference containing the given value. *)
-
-external ( ! ) : 'a ref -> 'a = "%field0"
-(** [!r] returns the current contents of reference [r].
- Equivalent to [fun r -> r.contents].
- Unary operator at precedence level 11/11.*)
-
-external ( := ) : 'a ref -> 'a -> unit = "%setfield0"
-(** [r := a] stores the value of [a] in reference [r].
- Equivalent to [fun r v -> r.contents <- v].
- Right-associative operator at precedence level 1/11. *)
-
-external incr : int ref -> unit = "%incr"
-(** Increment the integer contained in the given reference.
- Equivalent to [fun r -> r := succ !r]. *)
-
-external decr : int ref -> unit = "%decr"
-(** Decrement the integer contained in the given reference.
- Equivalent to [fun r -> r := pred !r]. *)
-
-(** {1 Result type} *)
-
-(** @since 4.03.0 *)
-type ('a,'b) result = Ok of 'a | Error of 'b
-
-(** {1 Operations on format strings} *)
-
-(** Format strings are character strings with special lexical conventions
- that defines the functionality of formatted input/output functions. Format
- strings are used to read data with formatted input functions from module
- {!Scanf} and to print data with formatted output functions from modules
- {!Printf} and {!Format}.
-
- Format strings are made of three kinds of entities:
- - {e conversions specifications}, introduced by the special character ['%']
- followed by one or more characters specifying what kind of argument to
- read or print,
- - {e formatting indications}, introduced by the special character ['@']
- followed by one or more characters specifying how to read or print the
- argument,
- - {e plain characters} that are regular characters with usual lexical
- conventions. Plain characters specify string literals to be read in the
- input or printed in the output.
-
- There is an additional lexical rule to escape the special characters ['%']
- and ['@'] in format strings: if a special character follows a ['%']
- character, it is treated as a plain character. In other words, ["%%"] is
- considered as a plain ['%'] and ["%@"] as a plain ['@'].
-
- For more information about conversion specifications and formatting
- indications available, read the documentation of modules {!Scanf},
- {!Printf} and {!Format}.
-*)
-
-(** Format strings have a general and highly polymorphic type
- [('a, 'b, 'c, 'd, 'e, 'f) format6].
- The two simplified types, [format] and [format4] below are
- included for backward compatibility with earlier releases of
- OCaml.
-
- The meaning of format string type parameters is as follows:
-
- - ['a] is the type of the parameters of the format for formatted output
- functions ([printf]-style functions);
- ['a] is the type of the values read by the format for formatted input
- functions ([scanf]-style functions).
-
- - ['b] is the type of input source for formatted input functions and the
- type of output target for formatted output functions.
- For [printf]-style functions from module {!Printf}, ['b] is typically
- [out_channel];
- for [printf]-style functions from module {!Format}, ['b] is typically
- {!Format.formatter};
- for [scanf]-style functions from module {!Scanf}, ['b] is typically
- {!Scanf.Scanning.in_channel}.
-
- Type argument ['b] is also the type of the first argument given to
- user's defined printing functions for [%a] and [%t] conversions,
- and user's defined reading functions for [%r] conversion.
-
- - ['c] is the type of the result of the [%a] and [%t] printing
- functions, and also the type of the argument transmitted to the
- first argument of [kprintf]-style functions or to the
- [kscanf]-style functions.
-
- - ['d] is the type of parameters for the [scanf]-style functions.
-
- - ['e] is the type of the receiver function for the [scanf]-style functions.
-
- - ['f] is the final result type of a formatted input/output function
- invocation: for the [printf]-style functions, it is typically [unit];
- for the [scanf]-style functions, it is typically the result type of the
- receiver function.
-*)
-
-type ('a, 'b, 'c, 'd, 'e, 'f) format6 =
- ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
-
-type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
-
-type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
-
-val string_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string
-(** Converts a format string into a string. *)
-
-external format_of_string :
- ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
- ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
-(** [format_of_string s] returns a format string read from the string
- literal [s].
- Note: [format_of_string] can not convert a string argument that is not a
- literal. If you need this functionality, use the more general
- {!Scanf.format_from_string} function.
-*)
-
-val ( ^^ ) :
- ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
- ('f, 'b, 'c, 'e, 'g, 'h) format6 ->
- ('a, 'b, 'c, 'd, 'g, 'h) format6
-(** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a
- format string that behaves as the concatenation of format strings [f1] and
- [f2]: in case of formatted output, it accepts arguments from [f1], then
- arguments from [f2]; in case of formatted input, it returns results from
- [f1], then results from [f2].
- Right-associative operator at precedence level 5/11. *)
-
-
-(** {1 Program termination} *)
-
-val exit : int -> 'a
-(** Terminate the process, returning the given status code
- to the operating system: usually 0 to indicate no errors,
- and a small positive integer to indicate failure.
- All open output channels are flushed with [flush_all].
- An implicit [exit 0] is performed each time a program
- terminates normally. An implicit [exit 2] is performed if the program
- terminates early because of an uncaught exception. *)
-
-val at_exit : (unit -> unit) -> unit
-(** Register the given function to be called at program termination
- time. The functions registered with [at_exit] will be called when
- the program does any of the following:
- - executes {!Pervasives.exit}
- - terminates, either normally or because of an uncaught
- exception
- - executes the C function [caml_shutdown].
- The functions are called in 'last in, first out' order: the
- function most recently added with [at_exit] is called first. *)
-
-(**/**)
-
-(* The following is for system use only. Do not call directly. *)
-
-val valid_float_lexem : string -> string
-
-val unsafe_really_input : in_channel -> bytes -> int -> int -> unit
-
-val do_at_exit : unit -> unit
last.next <- q1.first;
q2.last <- q1.last;
clear q1
+
+(** {6 Iterators} *)
+
+let to_seq q =
+ let rec aux c () = match c with
+ | Nil -> Seq.Nil
+ | Cons { content=x; next; } -> Seq.Cons (x, aux next)
+ in
+ aux q.first
+
+let add_seq q i = Seq.iter (fun x -> push x q) i
+
+let of_seq g =
+ let q = create() in
+ add_seq q g;
+ q
+
the queue [q2], then clears [q1]. It is equivalent to the
sequence [iter (fun x -> add x q2) q1; clear q1], but runs
in constant time. *)
+
+(** {6 Iterators} *)
+
+val to_seq : 'a t -> 'a Seq.t
+(** Iterate on the queue, in front-to-back order.
+ The behavior is not defined if the queue is modified
+ during the iteration.
+ @since 4.07 *)
+
+val add_seq : 'a t -> 'a Seq.t -> unit
+(** Add the elements from the generator to the end of the queue
+ @since 4.07 *)
+
+val of_seq : 'a Seq.t -> 'a t
+(** Create an array from the generator
+ @since 4.07 *)
+
--- /dev/null
+#**************************************************************************
+#* *
+#* OCaml *
+#* *
+#* Jeremie Dimino, Jane Street Europe *
+#* *
+#* Copyright 2017 Jane Street Group LLC *
+#* *
+#* All rights reserved. This file is distributed under the terms of *
+#* the GNU Lesser General Public License version 2.1, with the *
+#* special exception on linking described in the file LICENSE. *
+#* *
+#**************************************************************************
+
+# This script remove the module aliases from stdlib.ml and stdlib.mli
+# so that ocamldep doesn't register dependencies from stdlib to all
+# other modules
+BEGIN { in_aliases=0 }
+NR == 1 { printf ("# 1 \"%s\"\n", FILENAME) }
+/^\(\*MODULE_ALIASES\*\)\r?$/ { in_aliases=1 }
+!in_aliases { print }
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Simon Cruanes *)
+(* *)
+(* Copyright 2017 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Module [Seq]: functional iterators *)
+
+type +'a node =
+ | Nil
+ | Cons of 'a * 'a t
+
+and 'a t = unit -> 'a node
+
+let empty () = Nil
+
+let return x () = Cons (x, empty)
+
+let rec map f seq () = match seq() with
+ | Nil -> Nil
+ | Cons (x, next) -> Cons (f x, map f next)
+
+let rec filter_map f seq () = match seq() with
+ | Nil -> Nil
+ | Cons (x, next) ->
+ match f x with
+ | None -> filter_map f next ()
+ | Some y -> Cons (y, filter_map f next)
+
+let rec filter f seq () = match seq() with
+ | Nil -> Nil
+ | Cons (x, next) ->
+ if f x
+ then Cons (x, filter f next)
+ else filter f next ()
+
+let rec flat_map f seq () = match seq () with
+ | Nil -> Nil
+ | Cons (x, next) ->
+ flat_map_app f (f x) next ()
+
+(* this is [append seq (flat_map f tail)] *)
+and flat_map_app f seq tail () = match seq () with
+ | Nil -> flat_map f tail ()
+ | Cons (x, next) ->
+ Cons (x, flat_map_app f next tail)
+
+let fold_left f acc seq =
+ let rec aux f acc seq = match seq () with
+ | Nil -> acc
+ | Cons (x, next) ->
+ let acc = f acc x in
+ aux f acc next
+ in
+ aux f acc seq
+
+let iter f seq =
+ let rec aux seq = match seq () with
+ | Nil -> ()
+ | Cons (x, next) ->
+ f x;
+ aux next
+ in
+ aux seq
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Simon Cruanes *)
+(* *)
+(* Copyright 2017 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Module [Seq]: functional iterators *)
+
+(** {1 Functional Iterators} *)
+
+(** The type ['a t] is a {b delayed list}, i.e. a list where some evaluation
+ is needed to access the next element. This makes it possible to build
+ infinite sequences, to build sequences as we traverse them, and to transform
+ them in a lazy fashion rather than upfront.
+*)
+
+(** @since 4.07 *)
+
+type 'a t = unit -> 'a node
+(** The type of delayed lists containing elements of type ['a].
+ Note that the concrete list node ['a node] is delayed under a closure,
+ not a [lazy] block, which means it might be recomputed every time
+ we access it. *)
+
+and +'a node =
+ | Nil
+ | Cons of 'a * 'a t
+(** A fully-evaluated list node, either empty or containing an element
+ and a delayed tail. *)
+
+val empty : 'a t
+(** The empty sequence, containing no elements. *)
+
+val return : 'a -> 'a t
+(** The singleton sequence containing only the given element. *)
+
+val map : ('a -> 'b) -> 'a t -> 'b t
+(** [map f seq] returns a new sequence whose elements are the elements of
+ [seq], transformed by [f].
+ This transformation is lazy, it only applies when the result is traversed.
+
+ If [seq = [1;2;3]], then [map f seq = [f 1; f 2; f 3]]. *)
+
+val filter : ('a -> bool) -> 'a t -> 'a t
+(** Remove from the sequence the elements that do not satisfy the
+ given predicate.
+ This transformation is lazy, it only applies when the result is traversed. *)
+
+val filter_map : ('a -> 'b option) -> 'a t -> 'b t
+(** Apply the function to every element; if [f x = None] then [x] is dropped;
+ if [f x = Some y] then [y] is returned.
+ This transformation is lazy, it only applies when the result is traversed. *)
+
+val flat_map : ('a -> 'b t) -> 'a t -> 'b t
+(** Map each element to a subsequence, then return each element of this
+ sub-sequence in turn.
+ This transformation is lazy, it only applies when the result is traversed. *)
+
+val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
+(** Traverse the sequence from left to right, combining each element with the
+ accumulator using the given function.
+ The traversal happens immediately and will not terminate on infinite sequences.
+
+ Also see {!List.fold_left} *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** Iterate on the sequence, calling the (imperative) function on every element.
+ The traversal happens immediately and will not terminate on infinite sequences. *)
val find_last: (elt -> bool) -> t -> elt
val find_last_opt: (elt -> bool) -> t -> elt option
val of_list: elt list -> t
+ val to_seq_from : elt -> t -> elt Seq.t
+ val to_seq : t -> elt Seq.t
+ val add_seq : elt Seq.t -> t -> t
+ val of_seq : elt Seq.t -> t
end
module Make(Ord: OrderedType) =
| [x0; x1; x2; x3] -> add x3 (add x2 (add x1 (singleton x0)))
| [x0; x1; x2; x3; x4] -> add x4 (add x3 (add x2 (add x1 (singleton x0))))
| _ -> of_sorted_list (List.sort_uniq Ord.compare l)
+
+ let add_seq i m =
+ Seq.fold_left (fun s x -> add x s) m i
+
+ let of_seq i = add_seq i empty
+
+ let rec seq_of_enum_ c () = match c with
+ | End -> Seq.Nil
+ | More (x, t, rest) -> Seq.Cons (x, seq_of_enum_ (cons_enum t rest))
+
+ let to_seq c = seq_of_enum_ (cons_enum c End)
+
+ let to_seq_from low s =
+ let rec aux low s c = match s with
+ | Empty -> c
+ | Node {l; r; v; _} ->
+ begin match Ord.compare v low with
+ | 0 -> More (v, r, c)
+ | n when n<0 -> aux low r c
+ | _ -> aux low l (More (v, r, c))
+ end
+ in
+ seq_of_enum_ (aux low s End)
end
This is usually more efficient than folding [add] over the list,
except perhaps for lists with many duplicated elements.
@since 4.02.0 *)
+
+ (** {6 Iterators} *)
+
+ val to_seq_from : elt -> t -> elt Seq.t
+ (** [to_seq_from x s] iterates on a subset of the elements of [s]
+ in ascending order, from [x] or above.
+ @since 4.07 *)
+
+ val to_seq : t -> elt Seq.t
+ (** Iterate on the whole set, in ascending order
+ @since 4.07 *)
+
+ val add_seq : elt Seq.t -> t -> t
+ (** Add the given elements to the set, in order.
+ @since 4.07 *)
+
+ val of_seq : elt Seq.t -> t
+ (** Build a set from the given bindings
+ @since 4.07 *)
end
(** Output signature of the functor {!Set.Make}. *)
let iter f s = List.iter f s.c
let fold f acc s = List.fold_left f acc s.c
+
+(** {6 Iterators} *)
+
+let to_seq s = List.to_seq s.c
+
+let add_seq q i = Seq.iter (fun x -> push x q) i
+
+let of_seq g =
+ let s = create() in
+ add_seq s g;
+ s
+
where [x1] is the top of the stack, [x2] the second element,
and [xn] the bottom element. The stack is unchanged.
@since 4.03 *)
+
+(** {6 Iterators} *)
+
+val to_seq : 'a t -> 'a Seq.t
+(** Iterate on the stack, top to bottom.
+ It is safe to modify the stack during iteration.
+ @since 4.07 *)
+
+val add_seq : 'a t -> 'a Seq.t -> unit
+(** Add the elements from the iterator on the top of the stack.
+ @since 4.07 *)
+
+val of_seq : 'a Seq.t -> 'a t
+(** Create a stack from the iterator
+ @since 4.07 *)
+
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+module Pervasives = struct
+(* type 'a option = None | Some of 'a *)
+
+(* Exceptions *)
+
+external register_named_value : string -> 'a -> unit
+ = "caml_register_named_value"
+
+let () =
+ (* for asmrun/fail.c *)
+ register_named_value "Pervasives.array_bound_error"
+ (Invalid_argument "index out of bounds")
+
+
+external raise : exn -> 'a = "%raise"
+external raise_notrace : exn -> 'a = "%raise_notrace"
+
+let failwith s = raise(Failure s)
+let invalid_arg s = raise(Invalid_argument s)
+
+exception Exit
+
+(* Composition operators *)
+
+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
+
+(* Debugging *)
+
+external __LOC__ : string = "%loc_LOC"
+external __FILE__ : string = "%loc_FILE"
+external __LINE__ : int = "%loc_LINE"
+external __MODULE__ : string = "%loc_MODULE"
+external __POS__ : string * int * int * int = "%loc_POS"
+
+external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
+external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
+external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
+
+(* Comparisons *)
+
+external ( = ) : 'a -> 'a -> bool = "%equal"
+external ( <> ) : 'a -> 'a -> bool = "%notequal"
+external ( < ) : 'a -> 'a -> bool = "%lessthan"
+external ( > ) : 'a -> 'a -> bool = "%greaterthan"
+external ( <= ) : 'a -> 'a -> bool = "%lessequal"
+external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
+external compare : 'a -> 'a -> int = "%compare"
+
+let min x y = if x <= y then x else y
+let max x y = if x >= y then x else y
+
+external ( == ) : 'a -> 'a -> bool = "%eq"
+external ( != ) : 'a -> 'a -> bool = "%noteq"
+
+(* Boolean operations *)
+
+external not : bool -> bool = "%boolnot"
+external ( & ) : bool -> bool -> bool = "%sequand"
+external ( && ) : bool -> bool -> bool = "%sequand"
+external ( or ) : bool -> bool -> bool = "%sequor"
+external ( || ) : bool -> bool -> bool = "%sequor"
+
+(* Integer operations *)
+
+external ( ~- ) : int -> int = "%negint"
+external ( ~+ ) : int -> int = "%identity"
+external succ : int -> int = "%succint"
+external pred : int -> int = "%predint"
+external ( + ) : int -> int -> int = "%addint"
+external ( - ) : int -> int -> int = "%subint"
+external ( * ) : int -> int -> int = "%mulint"
+external ( / ) : int -> int -> int = "%divint"
+external ( mod ) : int -> int -> int = "%modint"
+
+let abs x = if x >= 0 then x else -x
+
+external ( land ) : int -> int -> int = "%andint"
+external ( lor ) : int -> int -> int = "%orint"
+external ( lxor ) : int -> int -> int = "%xorint"
+
+let lnot x = x lxor (-1)
+
+external ( lsl ) : int -> int -> int = "%lslint"
+external ( lsr ) : int -> int -> int = "%lsrint"
+external ( asr ) : int -> int -> int = "%asrint"
+
+let max_int = (-1) lsr 1
+let min_int = max_int + 1
+
+(* Floating-point operations *)
+
+external ( ~-. ) : float -> float = "%negfloat"
+external ( ~+. ) : float -> float = "%identity"
+external ( +. ) : float -> float -> float = "%addfloat"
+external ( -. ) : float -> float -> float = "%subfloat"
+external ( *. ) : float -> float -> float = "%mulfloat"
+external ( /. ) : float -> float -> float = "%divfloat"
+external ( ** ) : float -> float -> float = "caml_power_float" "pow"
+ [@@unboxed] [@@noalloc]
+external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc]
+external expm1 : float -> float = "caml_expm1_float" "caml_expm1"
+ [@@unboxed] [@@noalloc]
+external acos : float -> float = "caml_acos_float" "acos"
+ [@@unboxed] [@@noalloc]
+external asin : float -> float = "caml_asin_float" "asin"
+ [@@unboxed] [@@noalloc]
+external atan : float -> float = "caml_atan_float" "atan"
+ [@@unboxed] [@@noalloc]
+external atan2 : float -> float -> float = "caml_atan2_float" "atan2"
+ [@@unboxed] [@@noalloc]
+external hypot : float -> float -> float
+ = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc]
+external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc]
+external cosh : float -> float = "caml_cosh_float" "cosh"
+ [@@unboxed] [@@noalloc]
+external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc]
+external log10 : float -> float = "caml_log10_float" "log10"
+ [@@unboxed] [@@noalloc]
+external log1p : float -> float = "caml_log1p_float" "caml_log1p"
+ [@@unboxed] [@@noalloc]
+external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc]
+external sinh : float -> float = "caml_sinh_float" "sinh"
+ [@@unboxed] [@@noalloc]
+external sqrt : float -> float = "caml_sqrt_float" "sqrt"
+ [@@unboxed] [@@noalloc]
+external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc]
+external tanh : float -> float = "caml_tanh_float" "tanh"
+ [@@unboxed] [@@noalloc]
+external ceil : float -> float = "caml_ceil_float" "ceil"
+ [@@unboxed] [@@noalloc]
+external floor : float -> float = "caml_floor_float" "floor"
+ [@@unboxed] [@@noalloc]
+external abs_float : float -> float = "%absfloat"
+external copysign : float -> float -> float
+ = "caml_copysign_float" "caml_copysign"
+ [@@unboxed] [@@noalloc]
+external mod_float : float -> float -> float = "caml_fmod_float" "fmod"
+ [@@unboxed] [@@noalloc]
+external frexp : float -> float * int = "caml_frexp_float"
+external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
+ "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc]
+external modf : float -> float * float = "caml_modf_float"
+external float : int -> float = "%floatofint"
+external float_of_int : int -> float = "%floatofint"
+external truncate : float -> int = "%intoffloat"
+external int_of_float : float -> int = "%intoffloat"
+external float_of_bits : int64 -> float
+ = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed"
+ [@@unboxed] [@@noalloc]
+let infinity =
+ float_of_bits 0x7F_F0_00_00_00_00_00_00L
+let neg_infinity =
+ float_of_bits 0xFF_F0_00_00_00_00_00_00L
+let nan =
+ float_of_bits 0x7F_F0_00_00_00_00_00_01L
+let max_float =
+ float_of_bits 0x7F_EF_FF_FF_FF_FF_FF_FFL
+let min_float =
+ float_of_bits 0x00_10_00_00_00_00_00_00L
+let epsilon_float =
+ float_of_bits 0x3C_B0_00_00_00_00_00_00L
+
+type fpclass =
+ FP_normal
+ | FP_subnormal
+ | FP_zero
+ | FP_infinite
+ | FP_nan
+external classify_float : (float [@unboxed]) -> fpclass =
+ "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
+
+(* String and byte sequence operations -- more in modules String and Bytes *)
+
+external string_length : string -> int = "%string_length"
+external bytes_length : bytes -> int = "%bytes_length"
+external bytes_create : int -> bytes = "caml_create_bytes"
+external string_blit : string -> int -> bytes -> int -> int -> unit
+ = "caml_blit_string" [@@noalloc]
+external bytes_blit : bytes -> int -> bytes -> int -> int -> unit
+ = "caml_blit_bytes" [@@noalloc]
+external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
+
+let ( ^ ) s1 s2 =
+ let l1 = string_length s1 and l2 = string_length s2 in
+ let s = bytes_create (l1 + l2) in
+ string_blit s1 0 s 0 l1;
+ string_blit s2 0 s l1 l2;
+ bytes_unsafe_to_string s
+
+(* Character operations -- more in module Char *)
+
+external int_of_char : char -> int = "%identity"
+external unsafe_char_of_int : int -> char = "%identity"
+let char_of_int n =
+ if n < 0 || n > 255 then invalid_arg "char_of_int" else unsafe_char_of_int n
+
+(* Unit operations *)
+
+external ignore : 'a -> unit = "%ignore"
+
+(* Pair operations *)
+
+external fst : 'a * 'b -> 'a = "%field0"
+external snd : 'a * 'b -> 'b = "%field1"
+
+(* References *)
+
+type 'a ref = { mutable contents : 'a }
+external ref : 'a -> 'a ref = "%makemutable"
+external ( ! ) : 'a ref -> 'a = "%field0"
+external ( := ) : 'a ref -> 'a -> unit = "%setfield0"
+external incr : int ref -> unit = "%incr"
+external decr : int ref -> unit = "%decr"
+
+(* Result type *)
+
+type ('a,'b) result = Ok of 'a | Error of 'b
+
+(* String conversion functions *)
+
+external format_int : string -> int -> string = "caml_format_int"
+external format_float : string -> float -> string = "caml_format_float"
+
+let string_of_bool b =
+ if b then "true" else "false"
+let bool_of_string = function
+ | "true" -> true
+ | "false" -> false
+ | _ -> invalid_arg "bool_of_string"
+
+let bool_of_string_opt = function
+ | "true" -> Some true
+ | "false" -> Some false
+ | _ -> None
+
+let string_of_int n =
+ format_int "%d" n
+
+external int_of_string : string -> int = "caml_int_of_string"
+
+let int_of_string_opt s =
+ (* TODO: provide this directly as a non-raising primitive. *)
+ try Some (int_of_string s)
+ with Failure _ -> None
+
+external string_get : string -> int -> char = "%string_safe_get"
+
+let valid_float_lexem s =
+ let l = string_length s in
+ let rec loop i =
+ if i >= l then s ^ "." else
+ match string_get s i with
+ | '0' .. '9' | '-' -> loop (i + 1)
+ | _ -> s
+ in
+ loop 0
+
+let string_of_float f = valid_float_lexem (format_float "%.12g" f)
+
+external float_of_string : string -> float = "caml_float_of_string"
+
+let float_of_string_opt s =
+ (* TODO: provide this directly as a non-raising primitive. *)
+ try Some (float_of_string s)
+ with Failure _ -> None
+
+(* List operations -- more in module List *)
+
+let rec ( @ ) l1 l2 =
+ match l1 with
+ [] -> l2
+ | hd :: tl -> hd :: (tl @ l2)
+
+(* I/O operations *)
+
+type in_channel
+type out_channel
+
+external open_descriptor_out : int -> out_channel
+ = "caml_ml_open_descriptor_out"
+external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in"
+
+let stdin = open_descriptor_in 0
+let stdout = open_descriptor_out 1
+let stderr = open_descriptor_out 2
+
+(* General output functions *)
+
+type open_flag =
+ Open_rdonly | Open_wronly | Open_append
+ | Open_creat | Open_trunc | Open_excl
+ | Open_binary | Open_text | Open_nonblock
+
+external open_desc : string -> open_flag list -> int -> int = "caml_sys_open"
+
+external set_out_channel_name: out_channel -> string -> unit =
+ "caml_ml_set_channel_name"
+
+let open_out_gen mode perm name =
+ let c = open_descriptor_out(open_desc name mode perm) in
+ set_out_channel_name c name;
+ c
+
+let open_out name =
+ open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name
+
+let open_out_bin name =
+ open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name
+
+external flush : out_channel -> unit = "caml_ml_flush"
+
+external out_channels_list : unit -> out_channel list
+ = "caml_ml_out_channels_list"
+
+let flush_all () =
+ let rec iter = function
+ [] -> ()
+ | a::l ->
+ begin try
+ flush a
+ with Sys_error _ ->
+ () (* ignore channels closed during a preceding flush. *)
+ end;
+ iter l
+ in iter (out_channels_list ())
+
+external unsafe_output : out_channel -> bytes -> int -> int -> unit
+ = "caml_ml_output_bytes"
+external unsafe_output_string : out_channel -> string -> int -> int -> unit
+ = "caml_ml_output"
+
+external output_char : out_channel -> char -> unit = "caml_ml_output_char"
+
+let output_bytes oc s =
+ unsafe_output oc s 0 (bytes_length s)
+
+let output_string oc s =
+ unsafe_output_string oc s 0 (string_length s)
+
+let output oc s ofs len =
+ if ofs < 0 || len < 0 || ofs > bytes_length s - len
+ then invalid_arg "output"
+ else unsafe_output oc s ofs len
+
+let output_substring oc s ofs len =
+ if ofs < 0 || len < 0 || ofs > string_length s - len
+ then invalid_arg "output_substring"
+ else unsafe_output_string oc s ofs len
+
+external output_byte : out_channel -> int -> unit = "caml_ml_output_char"
+external output_binary_int : out_channel -> int -> unit = "caml_ml_output_int"
+
+external marshal_to_channel : out_channel -> 'a -> unit list -> unit
+ = "caml_output_value"
+let output_value chan v = marshal_to_channel chan v []
+
+external seek_out : out_channel -> int -> unit = "caml_ml_seek_out"
+external pos_out : out_channel -> int = "caml_ml_pos_out"
+external out_channel_length : out_channel -> int = "caml_ml_channel_size"
+external close_out_channel : out_channel -> unit = "caml_ml_close_channel"
+let close_out oc = flush oc; close_out_channel oc
+let close_out_noerr oc =
+ (try flush oc with _ -> ());
+ (try close_out_channel oc with _ -> ())
+external set_binary_mode_out : out_channel -> bool -> unit
+ = "caml_ml_set_binary_mode"
+
+(* General input functions *)
+
+external set_in_channel_name: in_channel -> string -> unit =
+ "caml_ml_set_channel_name"
+
+let open_in_gen mode perm name =
+ let c = open_descriptor_in(open_desc name mode perm) in
+ set_in_channel_name c name;
+ c
+
+let open_in name =
+ open_in_gen [Open_rdonly; Open_text] 0 name
+
+let open_in_bin name =
+ open_in_gen [Open_rdonly; Open_binary] 0 name
+
+external input_char : in_channel -> char = "caml_ml_input_char"
+
+external unsafe_input : in_channel -> bytes -> int -> int -> int
+ = "caml_ml_input"
+
+let input ic s ofs len =
+ if ofs < 0 || len < 0 || ofs > bytes_length s - len
+ then invalid_arg "input"
+ else unsafe_input ic s ofs len
+
+let rec unsafe_really_input ic s ofs len =
+ if len <= 0 then () else begin
+ let r = unsafe_input ic s ofs len in
+ if r = 0
+ then raise End_of_file
+ else unsafe_really_input ic s (ofs + r) (len - r)
+ end
+
+let really_input ic s ofs len =
+ if ofs < 0 || len < 0 || ofs > bytes_length s - len
+ then invalid_arg "really_input"
+ else unsafe_really_input ic s ofs len
+
+let really_input_string ic len =
+ let s = bytes_create len in
+ really_input ic s 0 len;
+ bytes_unsafe_to_string s
+
+external input_scan_line : in_channel -> int = "caml_ml_input_scan_line"
+
+let input_line chan =
+ let rec build_result buf pos = function
+ [] -> buf
+ | hd :: tl ->
+ let len = bytes_length hd in
+ bytes_blit hd 0 buf (pos - len) len;
+ build_result buf (pos - len) tl in
+ let rec scan accu len =
+ let n = input_scan_line chan in
+ if n = 0 then begin (* n = 0: we are at EOF *)
+ match accu with
+ [] -> raise End_of_file
+ | _ -> build_result (bytes_create len) len accu
+ end else if n > 0 then begin (* n > 0: newline found in buffer *)
+ let res = bytes_create (n - 1) in
+ ignore (unsafe_input chan res 0 (n - 1));
+ ignore (input_char chan); (* skip the newline *)
+ match accu with
+ [] -> res
+ | _ -> let len = len + n - 1 in
+ build_result (bytes_create len) len (res :: accu)
+ end else begin (* n < 0: newline not found *)
+ let beg = bytes_create (-n) in
+ ignore(unsafe_input chan beg 0 (-n));
+ scan (beg :: accu) (len - n)
+ end
+ in bytes_unsafe_to_string (scan [] 0)
+
+external input_byte : in_channel -> int = "caml_ml_input_char"
+external input_binary_int : in_channel -> int = "caml_ml_input_int"
+external input_value : in_channel -> 'a = "caml_input_value"
+external seek_in : in_channel -> int -> unit = "caml_ml_seek_in"
+external pos_in : in_channel -> int = "caml_ml_pos_in"
+external in_channel_length : in_channel -> int = "caml_ml_channel_size"
+external close_in : in_channel -> unit = "caml_ml_close_channel"
+let close_in_noerr ic = (try close_in ic with _ -> ())
+external set_binary_mode_in : in_channel -> bool -> unit
+ = "caml_ml_set_binary_mode"
+
+(* Output functions on standard output *)
+
+let print_char c = output_char stdout c
+let print_string s = output_string stdout s
+let print_bytes s = output_bytes stdout s
+let print_int i = output_string stdout (string_of_int i)
+let print_float f = output_string stdout (string_of_float f)
+let print_endline s =
+ output_string stdout s; output_char stdout '\n'; flush stdout
+let print_newline () = output_char stdout '\n'; flush stdout
+
+(* Output functions on standard error *)
+
+let prerr_char c = output_char stderr c
+let prerr_string s = output_string stderr s
+let prerr_bytes s = output_bytes stderr s
+let prerr_int i = output_string stderr (string_of_int i)
+let prerr_float f = output_string stderr (string_of_float f)
+let prerr_endline s =
+ output_string stderr s; output_char stderr '\n'; flush stderr
+let prerr_newline () = output_char stderr '\n'; flush stderr
+
+(* Input functions on standard input *)
+
+let read_line () = flush stdout; input_line stdin
+let read_int () = int_of_string(read_line())
+let read_int_opt () = int_of_string_opt(read_line())
+let read_float () = float_of_string(read_line())
+let read_float_opt () = float_of_string_opt(read_line())
+
+(* Operations on large files *)
+
+module LargeFile =
+ struct
+ external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64"
+ external pos_out : out_channel -> int64 = "caml_ml_pos_out_64"
+ external out_channel_length : out_channel -> int64
+ = "caml_ml_channel_size_64"
+ external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64"
+ external pos_in : in_channel -> int64 = "caml_ml_pos_in_64"
+ external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64"
+ end
+
+(* Formats *)
+
+type ('a, 'b, 'c, 'd, 'e, 'f) format6
+ = ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
+ = Format of ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt
+ * string
+
+type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
+
+type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
+
+let string_of_format (Format (_fmt, str)) = str
+
+external format_of_string :
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
+
+let ( ^^ ) (Format (fmt1, str1)) (Format (fmt2, str2)) =
+ Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2,
+ str1 ^ "%," ^ str2)
+
+(* Miscellaneous *)
+
+external sys_exit : int -> 'a = "caml_sys_exit"
+
+let exit_function = ref flush_all
+
+let at_exit f =
+ let g = !exit_function in
+ (* MPR#7253, MPR#7796: make sure "f" is executed only once *)
+ let f_already_ran = ref false in
+ exit_function :=
+ (fun () ->
+ if not !f_already_ran then begin f_already_ran := true; f() end;
+ g())
+
+let do_at_exit () = (!exit_function) ()
+
+let exit retcode =
+ do_at_exit ();
+ sys_exit retcode
+
+let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
+end
+
+include Pervasives
+
+(*MODULE_ALIASES*)
+module Arg = Arg
+module Array = Array
+module ArrayLabels = ArrayLabels
+module Bigarray = Bigarray
+module Buffer = Buffer
+module Bytes = Bytes
+module BytesLabels = BytesLabels
+module Callback = Callback
+module Char = Char
+module Complex = Complex
+module Digest = Digest
+module Ephemeron = Ephemeron
+module Filename = Filename
+module Float = Float
+module Format = Format
+module Gc = Gc
+module Genlex = Genlex
+module Hashtbl = Hashtbl
+module Int32 = Int32
+module Int64 = Int64
+module Lazy = Lazy
+module Lexing = Lexing
+module List = List
+module ListLabels = ListLabels
+module Map = Map
+module Marshal = Marshal
+module MoreLabels = MoreLabels
+module Nativeint = Nativeint
+module Obj = Obj
+module Oo = Oo
+module Parsing = Parsing
+module Printexc = Printexc
+module Printf = Printf
+module Queue = Queue
+module Random = Random
+module Scanf = Scanf
+module Seq = Seq
+module Set = Set
+module Sort = Sort
+module Spacetime = Spacetime
+module Stack = Stack
+module StdLabels = StdLabels
+module Stream = Stream
+module String = String
+module StringLabels = StringLabels
+module Sys = Sys
+module Uchar = Uchar
+module Weak = Weak
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(** The OCaml Standard library.
+
+ This module is automatically opened at the beginning of each
+ compilation. All components of this module can therefore be
+ referred by their short name, without prefixing them by [Stdlib].
+*)
+
+module Pervasives : sig
+(** Pervasive operations.
+
+ This module provides the basic operations over the built-in types
+ (numbers, booleans, byte sequences, strings, exceptions, references,
+ lists, arrays, input-output channels, ...).
+
+ This module is included in the toplevel [Stdlib] module.
+*)
+
+
+(** {1 Exceptions} *)
+
+external raise : exn -> 'a = "%raise"
+(** Raise the given exception value *)
+
+external raise_notrace : exn -> 'a = "%raise_notrace"
+(** A faster version [raise] which does not record the backtrace.
+ @since 4.02.0
+*)
+
+val invalid_arg : string -> 'a
+(** Raise exception [Invalid_argument] with the given string. *)
+
+val failwith : string -> 'a
+(** Raise exception [Failure] with the given string. *)
+
+exception Exit
+(** The [Exit] exception is not raised by any library function. It is
+ provided for use in your programs. *)
+
+
+(** {1 Comparisons} *)
+
+external ( = ) : 'a -> 'a -> bool = "%equal"
+(** [e1 = e2] tests for structural equality of [e1] and [e2].
+ Mutable structures (e.g. references and arrays) are equal
+ if and only if their current contents are structurally equal,
+ even if the two mutable objects are not the same physical object.
+ Equality between functional values raises [Invalid_argument].
+ Equality between cyclic data structures may not terminate.
+ Left-associative operator at precedence level 4/11. *)
+
+external ( <> ) : 'a -> 'a -> bool = "%notequal"
+(** Negation of {!Pervasives.( = )}.
+ Left-associative operator at precedence level 4/11. *)
+
+external ( < ) : 'a -> 'a -> bool = "%lessthan"
+(** See {!Pervasives.( >= )}.
+ Left-associative operator at precedence level 4/11. *)
+
+external ( > ) : 'a -> 'a -> bool = "%greaterthan"
+(** See {!Pervasives.( >= )}.
+ Left-associative operator at precedence level 4/11. *)
+
+external ( <= ) : 'a -> 'a -> bool = "%lessequal"
+(** See {!Pervasives.( >= )}.
+ Left-associative operator at precedence level 4/11. *)
+
+external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
+(** Structural ordering functions. These functions coincide with
+ the usual orderings over integers, characters, strings, byte sequences
+ and floating-point numbers, and extend them to a
+ total ordering over all types.
+ The ordering is compatible with [( = )]. As in the case
+ of [( = )], mutable structures are compared by contents.
+ Comparison between functional values raises [Invalid_argument].
+ Comparison between cyclic structures may not terminate.
+ Left-associative operator at precedence level 4/11. *)
+
+external compare : 'a -> 'a -> int = "%compare"
+(** [compare x y] returns [0] if [x] is equal to [y],
+ a negative integer if [x] is less than [y], and a positive integer
+ if [x] is greater than [y]. The ordering implemented by [compare]
+ is compatible with the comparison predicates [=], [<] and [>]
+ defined above, with one difference on the treatment of the float value
+ {!Pervasives.nan}. Namely, the comparison predicates treat [nan]
+ as different from any other float value, including itself;
+ while [compare] treats [nan] as equal to itself and less than any
+ other float value. This treatment of [nan] ensures that [compare]
+ defines a total ordering relation.
+
+ [compare] applied to functional values may raise [Invalid_argument].
+ [compare] applied to cyclic structures may not terminate.
+
+ The [compare] function can be used as the comparison function
+ required by the {!Set.Make} and {!Map.Make} functors, as well as
+ the {!List.sort} and {!Array.sort} functions. *)
+
+val min : 'a -> 'a -> 'a
+(** Return the smaller of the two arguments.
+ The result is unspecified if one of the arguments contains
+ the float value [nan]. *)
+
+val max : 'a -> 'a -> 'a
+(** Return the greater of the two arguments.
+ The result is unspecified if one of the arguments contains
+ the float value [nan]. *)
+
+external ( == ) : 'a -> 'a -> bool = "%eq"
+(** [e1 == e2] tests for physical equality of [e1] and [e2].
+ On mutable types such as references, arrays, byte sequences, records with
+ mutable fields and objects with mutable instance variables,
+ [e1 == e2] is true if and only if physical modification of [e1]
+ also affects [e2].
+ On non-mutable types, the behavior of [( == )] is
+ implementation-dependent; however, it is guaranteed that
+ [e1 == e2] implies [compare e1 e2 = 0].
+ Left-associative operator at precedence level 4/11. *)
+
+external ( != ) : 'a -> 'a -> bool = "%noteq"
+(** Negation of {!Pervasives.( == )}.
+ Left-associative operator at precedence level 4/11. *)
+
+
+(** {1 Boolean operations} *)
+
+external not : bool -> bool = "%boolnot"
+(** The boolean negation. *)
+
+external ( && ) : bool -> bool -> bool = "%sequand"
+(** The boolean 'and'. Evaluation is sequential, left-to-right:
+ in [e1 && e2], [e1] is evaluated first, and if it returns [false],
+ [e2] is not evaluated at all.
+ Right-associative operator at precedence level 3/11. *)
+
+external ( & ) : bool -> bool -> bool = "%sequand"
+ [@@ocaml.deprecated "Use (&&) instead."]
+(** @deprecated {!Pervasives.( && )} should be used instead.
+ Right-associative operator at precedence level 3/11. *)
+
+external ( || ) : bool -> bool -> bool = "%sequor"
+(** The boolean 'or'. Evaluation is sequential, left-to-right:
+ in [e1 || e2], [e1] is evaluated first, and if it returns [true],
+ [e2] is not evaluated at all.
+ Right-associative operator at precedence level 2/11.
+*)
+
+external ( or ) : bool -> bool -> bool = "%sequor"
+ [@@ocaml.deprecated "Use (||) instead."]
+(** @deprecated {!Pervasives.( || )} should be used instead.
+ Right-associative operator at precedence level 2/11. *)
+
+(** {1 Debugging} *)
+
+external __LOC__ : string = "%loc_LOC"
+(** [__LOC__] returns the location at which this expression appears in
+ the file currently being parsed by the compiler, with the standard
+ error format of OCaml: "File %S, line %d, characters %d-%d".
+ @since 4.02.0
+*)
+
+external __FILE__ : string = "%loc_FILE"
+(** [__FILE__] returns the name of the file currently being
+ parsed by the compiler.
+ @since 4.02.0
+*)
+
+external __LINE__ : int = "%loc_LINE"
+(** [__LINE__] returns the line number at which this expression
+ appears in the file currently being parsed by the compiler.
+ @since 4.02.0
+*)
+
+external __MODULE__ : string = "%loc_MODULE"
+(** [__MODULE__] returns the module name of the file being
+ parsed by the compiler.
+ @since 4.02.0
+*)
+
+external __POS__ : string * int * int * int = "%loc_POS"
+(** [__POS__] returns a tuple [(file,lnum,cnum,enum)], corresponding
+ to the location at which this expression appears in the file
+ currently being parsed by the compiler. [file] is the current
+ filename, [lnum] the line number, [cnum] the character position in
+ the line and [enum] the last character position in the line.
+ @since 4.02.0
+ *)
+
+external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
+(** [__LOC_OF__ expr] returns a pair [(loc, expr)] where [loc] is the
+ location of [expr] in the file currently being parsed by the
+ compiler, with the standard error format of OCaml: "File %S, line
+ %d, characters %d-%d".
+ @since 4.02.0
+*)
+
+external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
+(** [__LINE_OF__ expr] returns a pair [(line, expr)], where [line] is the
+ line number at which the expression [expr] appears in the file
+ currently being parsed by the compiler.
+ @since 4.02.0
+ *)
+
+external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
+(** [__POS_OF__ expr] returns a pair [(loc,expr)], where [loc] is a
+ tuple [(file,lnum,cnum,enum)] corresponding to the location at
+ which the expression [expr] appears in the file currently being
+ parsed by the compiler. [file] is the current filename, [lnum] the
+ line number, [cnum] the character position in the line and [enum]
+ the last character position in the line.
+ @since 4.02.0
+ *)
+
+(** {1 Composition operators} *)
+
+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+(** Reverse-application operator: [x |> f |> g] is exactly equivalent
+ to [g (f (x))].
+ Left-associative operator at precedence level 4/11.
+ @since 4.01
+ *)
+
+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
+(** Application operator: [g @@ f @@ x] is exactly equivalent to
+ [g (f (x))].
+ Right-associative operator at precedence level 5/11.
+ @since 4.01
+*)
+
+(** {1 Integer arithmetic} *)
+
+(** Integers are [Sys.int_size] bits wide.
+ All operations are taken modulo 2{^[Sys.int_size]}.
+ They do not fail on overflow. *)
+
+external ( ~- ) : int -> int = "%negint"
+(** Unary negation. You can also write [- e] instead of [~- e].
+ Unary operator at precedence level 9/11 for [- e]
+ and 11/11 for [~- e]. *)
+
+external ( ~+ ) : int -> int = "%identity"
+(** Unary addition. You can also write [+ e] instead of [~+ e].
+ Unary operator at precedence level 9/11 for [+ e]
+ and 11/11 for [~+ e].
+ @since 3.12.0
+*)
+
+external succ : int -> int = "%succint"
+(** [succ x] is [x + 1]. *)
+
+external pred : int -> int = "%predint"
+(** [pred x] is [x - 1]. *)
+
+external ( + ) : int -> int -> int = "%addint"
+(** Integer addition.
+ Left-associative operator at precedence level 6/11. *)
+
+external ( - ) : int -> int -> int = "%subint"
+(** Integer subtraction.
+ Left-associative operator at precedence level 6/11. *)
+
+external ( * ) : int -> int -> int = "%mulint"
+(** Integer multiplication.
+ Left-associative operator at precedence level 7/11. *)
+
+external ( / ) : int -> int -> int = "%divint"
+(** Integer division.
+ Raise [Division_by_zero] if the second argument is 0.
+ Integer division rounds the real quotient of its arguments towards zero.
+ More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer
+ less than or equal to the real quotient of [x] by [y]. Moreover,
+ [(- x) / y = x / (- y) = - (x / y)].
+ Left-associative operator at precedence level 7/11. *)
+
+external ( mod ) : int -> int -> int = "%modint"
+(** Integer remainder. If [y] is not zero, the result
+ of [x mod y] satisfies the following properties:
+ [x = (x / y) * y + x mod y] and
+ [abs(x mod y) <= abs(y) - 1].
+ If [y = 0], [x mod y] raises [Division_by_zero].
+ Note that [x mod y] is negative only if [x < 0].
+ Raise [Division_by_zero] if [y] is zero.
+ Left-associative operator at precedence level 7/11. *)
+
+val abs : int -> int
+(** Return the absolute value of the argument. Note that this may be
+ negative if the argument is [min_int]. *)
+
+val max_int : int
+(** The greatest representable integer. *)
+
+val min_int : int
+(** The smallest representable integer. *)
+
+
+(** {2 Bitwise operations} *)
+
+external ( land ) : int -> int -> int = "%andint"
+(** Bitwise logical and.
+ Left-associative operator at precedence level 7/11. *)
+
+external ( lor ) : int -> int -> int = "%orint"
+(** Bitwise logical or.
+ Left-associative operator at precedence level 7/11. *)
+
+external ( lxor ) : int -> int -> int = "%xorint"
+(** Bitwise logical exclusive or.
+ Left-associative operator at precedence level 7/11. *)
+
+val lnot : int -> int
+(** Bitwise logical negation. *)
+
+external ( lsl ) : int -> int -> int = "%lslint"
+(** [n lsl m] shifts [n] to the left by [m] bits.
+ The result is unspecified if [m < 0] or [m > Sys.int_size].
+ Right-associative operator at precedence level 8/11. *)
+
+external ( lsr ) : int -> int -> int = "%lsrint"
+(** [n lsr m] shifts [n] to the right by [m] bits.
+ This is a logical shift: zeroes are inserted regardless of
+ the sign of [n].
+ The result is unspecified if [m < 0] or [m > Sys.int_size].
+ Right-associative operator at precedence level 8/11. *)
+
+external ( asr ) : int -> int -> int = "%asrint"
+(** [n asr m] shifts [n] to the right by [m] bits.
+ This is an arithmetic shift: the sign bit of [n] is replicated.
+ The result is unspecified if [m < 0] or [m > Sys.int_size].
+ Right-associative operator at precedence level 8/11. *)
+
+
+(** {1 Floating-point arithmetic}
+
+ OCaml's floating-point numbers follow the
+ IEEE 754 standard, using double precision (64 bits) numbers.
+ Floating-point operations never raise an exception on overflow,
+ underflow, division by zero, etc. Instead, special IEEE numbers
+ are returned as appropriate, such as [infinity] for [1.0 /. 0.0],
+ [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number')
+ for [0.0 /. 0.0]. These special numbers then propagate through
+ floating-point computations as expected: for instance,
+ [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan]
+ as argument returns [nan] as result.
+*)
+
+external ( ~-. ) : float -> float = "%negfloat"
+(** Unary negation. You can also write [-. e] instead of [~-. e].
+ Unary operator at precedence level 9/11 for [-. e]
+ and 11/11 for [~-. e]. *)
+
+external ( ~+. ) : float -> float = "%identity"
+(** Unary addition. You can also write [+. e] instead of [~+. e].
+ Unary operator at precedence level 9/11 for [+. e]
+ and 11/11 for [~+. e].
+ @since 3.12.0
+*)
+
+external ( +. ) : float -> float -> float = "%addfloat"
+(** Floating-point addition.
+ Left-associative operator at precedence level 6/11. *)
+
+external ( -. ) : float -> float -> float = "%subfloat"
+(** Floating-point subtraction.
+ Left-associative operator at precedence level 6/11. *)
+
+external ( *. ) : float -> float -> float = "%mulfloat"
+(** Floating-point multiplication.
+ Left-associative operator at precedence level 7/11. *)
+
+external ( /. ) : float -> float -> float = "%divfloat"
+(** Floating-point division.
+ Left-associative operator at precedence level 7/11. *)
+
+external ( ** ) : float -> float -> float = "caml_power_float" "pow"
+ [@@unboxed] [@@noalloc]
+(** Exponentiation.
+ Right-associative operator at precedence level 8/11. *)
+
+external sqrt : float -> float = "caml_sqrt_float" "sqrt"
+ [@@unboxed] [@@noalloc]
+(** Square root. *)
+
+external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc]
+(** Exponential. *)
+
+external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc]
+(** Natural logarithm. *)
+
+external log10 : float -> float = "caml_log10_float" "log10"
+ [@@unboxed] [@@noalloc]
+(** Base 10 logarithm. *)
+
+external expm1 : float -> float = "caml_expm1_float" "caml_expm1"
+ [@@unboxed] [@@noalloc]
+(** [expm1 x] computes [exp x -. 1.0], giving numerically-accurate results
+ even if [x] is close to [0.0].
+ @since 3.12.0
+*)
+
+external log1p : float -> float = "caml_log1p_float" "caml_log1p"
+ [@@unboxed] [@@noalloc]
+(** [log1p x] computes [log(1.0 +. x)] (natural logarithm),
+ giving numerically-accurate results even if [x] is close to [0.0].
+ @since 3.12.0
+*)
+
+external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc]
+(** Cosine. Argument is in radians. *)
+
+external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc]
+(** Sine. Argument is in radians. *)
+
+external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc]
+(** Tangent. Argument is in radians. *)
+
+external acos : float -> float = "caml_acos_float" "acos"
+ [@@unboxed] [@@noalloc]
+(** Arc cosine. The argument must fall within the range [[-1.0, 1.0]].
+ Result is in radians and is between [0.0] and [pi]. *)
+
+external asin : float -> float = "caml_asin_float" "asin"
+ [@@unboxed] [@@noalloc]
+(** Arc sine. The argument must fall within the range [[-1.0, 1.0]].
+ Result is in radians and is between [-pi/2] and [pi/2]. *)
+
+external atan : float -> float = "caml_atan_float" "atan"
+ [@@unboxed] [@@noalloc]
+(** Arc tangent.
+ Result is in radians and is between [-pi/2] and [pi/2]. *)
+
+external atan2 : float -> float -> float = "caml_atan2_float" "atan2"
+ [@@unboxed] [@@noalloc]
+(** [atan2 y x] returns the arc tangent of [y /. x]. The signs of [x]
+ and [y] are used to determine the quadrant of the result.
+ Result is in radians and is between [-pi] and [pi]. *)
+
+external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot"
+ [@@unboxed] [@@noalloc]
+(** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length
+ of the hypotenuse of a right-angled triangle with sides of length
+ [x] and [y], or, equivalently, the distance of the point [(x,y)]
+ to origin. If one of [x] or [y] is infinite, returns [infinity]
+ even if the other is [nan].
+ @since 4.00.0 *)
+
+external cosh : float -> float = "caml_cosh_float" "cosh"
+ [@@unboxed] [@@noalloc]
+(** Hyperbolic cosine. Argument is in radians. *)
+
+external sinh : float -> float = "caml_sinh_float" "sinh"
+ [@@unboxed] [@@noalloc]
+(** Hyperbolic sine. Argument is in radians. *)
+
+external tanh : float -> float = "caml_tanh_float" "tanh"
+ [@@unboxed] [@@noalloc]
+(** Hyperbolic tangent. Argument is in radians. *)
+
+external ceil : float -> float = "caml_ceil_float" "ceil"
+ [@@unboxed] [@@noalloc]
+(** Round above to an integer value.
+ [ceil f] returns the least integer value greater than or equal to [f].
+ The result is returned as a float. *)
+
+external floor : float -> float = "caml_floor_float" "floor"
+ [@@unboxed] [@@noalloc]
+(** Round below to an integer value.
+ [floor f] returns the greatest integer value less than or
+ equal to [f].
+ The result is returned as a float. *)
+
+external abs_float : float -> float = "%absfloat"
+(** [abs_float f] returns the absolute value of [f]. *)
+
+external copysign : float -> float -> float
+ = "caml_copysign_float" "caml_copysign"
+ [@@unboxed] [@@noalloc]
+(** [copysign x y] returns a float whose absolute value is that of [x]
+ and whose sign is that of [y]. If [x] is [nan], returns [nan].
+ If [y] is [nan], returns either [x] or [-. x], but it is not
+ specified which.
+ @since 4.00.0 *)
+
+external mod_float : float -> float -> float = "caml_fmod_float" "fmod"
+ [@@unboxed] [@@noalloc]
+(** [mod_float a b] returns the remainder of [a] with respect to
+ [b]. The returned value is [a -. n *. b], where [n]
+ is the quotient [a /. b] rounded towards zero to an integer. *)
+
+external frexp : float -> float * int = "caml_frexp_float"
+(** [frexp f] returns the pair of the significant
+ and the exponent of [f]. When [f] is zero, the
+ significant [x] and the exponent [n] of [f] are equal to
+ zero. When [f] is non-zero, they are defined by
+ [f = x *. 2 ** n] and [0.5 <= x < 1.0]. *)
+
+
+external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
+ "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc]
+(** [ldexp x n] returns [x *. 2 ** n]. *)
+
+external modf : float -> float * float = "caml_modf_float"
+(** [modf f] returns the pair of the fractional and integral
+ part of [f]. *)
+
+external float : int -> float = "%floatofint"
+(** Same as {!Pervasives.float_of_int}. *)
+
+external float_of_int : int -> float = "%floatofint"
+(** Convert an integer to floating-point. *)
+
+external truncate : float -> int = "%intoffloat"
+(** Same as {!Pervasives.int_of_float}. *)
+
+external int_of_float : float -> int = "%intoffloat"
+(** Truncate the given floating-point number to an integer.
+ The result is unspecified if the argument is [nan] or falls outside the
+ range of representable integers. *)
+
+val infinity : float
+(** Positive infinity. *)
+
+val neg_infinity : float
+(** Negative infinity. *)
+
+val nan : float
+(** A special floating-point value denoting the result of an
+ undefined operation such as [0.0 /. 0.0]. Stands for
+ 'not a number'. Any floating-point operation with [nan] as
+ argument returns [nan] as result. As for floating-point comparisons,
+ [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true]
+ if one or both of their arguments is [nan]. *)
+
+val max_float : float
+(** The largest positive finite value of type [float]. *)
+
+val min_float : float
+(** The smallest positive, non-zero, non-denormalized value of type [float]. *)
+
+val epsilon_float : float
+(** The difference between [1.0] and the smallest exactly representable
+ floating-point number greater than [1.0]. *)
+
+type fpclass =
+ FP_normal (** Normal number, none of the below *)
+ | FP_subnormal (** Number very close to 0.0, has reduced precision *)
+ | FP_zero (** Number is 0.0 or -0.0 *)
+ | FP_infinite (** Number is positive or negative infinity *)
+ | FP_nan (** Not a number: result of an undefined operation *)
+(** The five classes of floating-point numbers, as determined by
+ the {!Pervasives.classify_float} function. *)
+
+external classify_float : (float [@unboxed]) -> fpclass =
+ "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
+(** Return the class of the given floating-point number:
+ normal, subnormal, zero, infinite, or not a number. *)
+
+
+(** {1 String operations}
+
+ More string operations are provided in module {!String}.
+*)
+
+val ( ^ ) : string -> string -> string
+(** String concatenation.
+ Right-associative operator at precedence level 5/11. *)
+
+
+(** {1 Character operations}
+
+ More character operations are provided in module {!Char}.
+*)
+
+external int_of_char : char -> int = "%identity"
+(** Return the ASCII code of the argument. *)
+
+val char_of_int : int -> char
+(** Return the character with the given ASCII code.
+ Raise [Invalid_argument "char_of_int"] if the argument is
+ outside the range 0--255. *)
+
+
+(** {1 Unit operations} *)
+
+external ignore : 'a -> unit = "%ignore"
+(** Discard the value of its argument and return [()].
+ For instance, [ignore(f x)] discards the result of
+ the side-effecting function [f]. It is equivalent to
+ [f x; ()], except that the latter may generate a
+ compiler warning; writing [ignore(f x)] instead
+ avoids the warning. *)
+
+
+(** {1 String conversion functions} *)
+
+val string_of_bool : bool -> string
+(** Return the string representation of a boolean. As the returned values
+ may be shared, the user should not modify them directly.
+*)
+
+val bool_of_string : string -> bool
+(** Convert the given string to a boolean.
+ Raise [Invalid_argument "bool_of_string"] if the string is not
+ ["true"] or ["false"]. *)
+
+val bool_of_string_opt: string -> bool option
+(** Convert the given string to a boolean.
+ Return [None] if the string is not
+ ["true"] or ["false"].
+ @since 4.05
+*)
+
+val string_of_int : int -> string
+(** Return the string representation of an integer, in decimal. *)
+
+external int_of_string : string -> int = "caml_int_of_string"
+(** Convert the given string to an integer.
+ The string is read in decimal (by default, or if the string
+ begins with [0u]), in hexadecimal (if it begins with [0x] or
+ [0X]), in octal (if it begins with [0o] or [0O]), or in binary
+ (if it begins with [0b] or [0B]).
+
+ The [0u] prefix reads the input as an unsigned integer in the range
+ [[0, 2*max_int+1]]. If the input exceeds {!max_int}
+ it is converted to the signed integer
+ [min_int + input - max_int - 1].
+
+ The [_] (underscore) character can appear anywhere in the string
+ and is ignored.
+ Raise [Failure "int_of_string"] if the given string is not
+ a valid representation of an integer, or if the integer represented
+ exceeds the range of integers representable in type [int]. *)
+
+
+val int_of_string_opt: string -> int option
+(** Same as [int_of_string], but returns [None] instead of raising.
+ @since 4.05
+*)
+
+val string_of_float : float -> string
+(** Return the string representation of a floating-point number. *)
+
+external float_of_string : string -> float = "caml_float_of_string"
+(** Convert the given string to a float. The string is read in decimal
+ (by default) or in hexadecimal (marked by [0x] or [0X]).
+ The format of decimal floating-point numbers is
+ [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit.
+ The format of hexadecimal floating-point numbers is
+ [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an
+ hexadecimal digit and [d] for a decimal digit.
+ In both cases, at least one of the integer and fractional parts must be
+ given; the exponent part is optional.
+ The [_] (underscore) character can appear anywhere in the string
+ and is ignored.
+ Depending on the execution platforms, other representations of
+ floating-point numbers can be accepted, but should not be relied upon.
+ Raise [Failure "float_of_string"] if the given string is not a valid
+ representation of a float. *)
+
+val float_of_string_opt: string -> float option
+(** Same as [float_of_string], but returns [None] instead of raising.
+ @since 4.05
+*)
+
+(** {1 Pair operations} *)
+
+external fst : 'a * 'b -> 'a = "%field0"
+(** Return the first component of a pair. *)
+
+external snd : 'a * 'b -> 'b = "%field1"
+(** Return the second component of a pair. *)
+
+
+(** {1 List operations}
+
+ More list operations are provided in module {!List}.
+*)
+
+val ( @ ) : 'a list -> 'a list -> 'a list
+(** List concatenation. Not tail-recursive (length of the first argument).
+ Right-associative operator at precedence level 5/11. *)
+
+
+(** {1 Input/output}
+ Note: all input/output functions can raise [Sys_error] when the system
+ calls they invoke fail. *)
+
+type in_channel
+(** The type of input channel. *)
+
+type out_channel
+(** The type of output channel. *)
+
+val stdin : in_channel
+(** The standard input for the process. *)
+
+val stdout : out_channel
+(** The standard output for the process. *)
+
+val stderr : out_channel
+(** The standard error output for the process. *)
+
+
+(** {2 Output functions on standard output} *)
+
+val print_char : char -> unit
+(** Print a character on standard output. *)
+
+val print_string : string -> unit
+(** Print a string on standard output. *)
+
+val print_bytes : bytes -> unit
+(** Print a byte sequence on standard output.
+ @since 4.02.0 *)
+
+val print_int : int -> unit
+(** Print an integer, in decimal, on standard output. *)
+
+val print_float : float -> unit
+(** Print a floating-point number, in decimal, on standard output. *)
+
+val print_endline : string -> unit
+(** Print a string, followed by a newline character, on
+ standard output and flush standard output. *)
+
+val print_newline : unit -> unit
+(** Print a newline character on standard output, and flush
+ standard output. This can be used to simulate line
+ buffering of standard output. *)
+
+
+(** {2 Output functions on standard error} *)
+
+val prerr_char : char -> unit
+(** Print a character on standard error. *)
+
+val prerr_string : string -> unit
+(** Print a string on standard error. *)
+
+val prerr_bytes : bytes -> unit
+(** Print a byte sequence on standard error.
+ @since 4.02.0 *)
+
+val prerr_int : int -> unit
+(** Print an integer, in decimal, on standard error. *)
+
+val prerr_float : float -> unit
+(** Print a floating-point number, in decimal, on standard error. *)
+
+val prerr_endline : string -> unit
+(** Print a string, followed by a newline character on standard
+ error and flush standard error. *)
+
+val prerr_newline : unit -> unit
+(** Print a newline character on standard error, and flush
+ standard error. *)
+
+
+(** {2 Input functions on standard input} *)
+
+val read_line : unit -> string
+(** Flush standard output, then read characters from standard input
+ until a newline character is encountered. Return the string of
+ all characters read, without the newline character at the end. *)
+
+val read_int : unit -> int
+(** Flush standard output, then read one line from standard input
+ and convert it to an integer. Raise [Failure "int_of_string"]
+ if the line read is not a valid representation of an integer. *)
+
+val read_int_opt: unit -> int option
+(** Same as [read_int_opt], but returns [None] instead of raising.
+ @since 4.05
+*)
+
+val read_float : unit -> float
+(** Flush standard output, then read one line from standard input
+ and convert it to a floating-point number.
+ The result is unspecified if the line read is not a valid
+ representation of a floating-point number. *)
+
+val read_float_opt: unit -> float option
+(** Flush standard output, then read one line from standard input
+ and convert it to a floating-point number.
+ Returns [None] if the line read is not a valid
+ representation of a floating-point number.
+ @since 4.05.0 *)
+
+
+(** {2 General output functions} *)
+
+type open_flag =
+ Open_rdonly (** open for reading. *)
+ | Open_wronly (** open for writing. *)
+ | Open_append (** open for appending: always write at end of file. *)
+ | Open_creat (** create the file if it does not exist. *)
+ | Open_trunc (** empty the file if it already exists. *)
+ | Open_excl (** fail if Open_creat and the file already exists. *)
+ | Open_binary (** open in binary mode (no conversion). *)
+ | Open_text (** open in text mode (may perform conversions). *)
+ | Open_nonblock (** open in non-blocking mode. *)
+(** Opening modes for {!Pervasives.open_out_gen} and
+ {!Pervasives.open_in_gen}. *)
+
+val open_out : string -> out_channel
+(** Open the named file for writing, and return a new output channel
+ on that file, positioned at the beginning of the file. The
+ file is truncated to zero length if it already exists. It
+ is created if it does not already exists. *)
+
+val open_out_bin : string -> out_channel
+(** Same as {!Pervasives.open_out}, but the file is opened in binary mode,
+ so that no translation takes place during writes. On operating
+ systems that do not distinguish between text mode and binary
+ mode, this function behaves like {!Pervasives.open_out}. *)
+
+val open_out_gen : open_flag list -> int -> string -> out_channel
+(** [open_out_gen mode perm filename] opens the named file for writing,
+ as described above. The extra argument [mode]
+ specifies the opening mode. The extra argument [perm] specifies
+ the file permissions, in case the file must be created.
+ {!Pervasives.open_out} and {!Pervasives.open_out_bin} are special
+ cases of this function. *)
+
+val flush : out_channel -> unit
+(** Flush the buffer associated with the given output channel,
+ performing all pending writes on that channel.
+ Interactive programs must be careful about flushing standard
+ output and standard error at the right time. *)
+
+val flush_all : unit -> unit
+(** Flush all open output channels; ignore errors. *)
+
+val output_char : out_channel -> char -> unit
+(** Write the character on the given output channel. *)
+
+val output_string : out_channel -> string -> unit
+(** Write the string on the given output channel. *)
+
+val output_bytes : out_channel -> bytes -> unit
+(** Write the byte sequence on the given output channel.
+ @since 4.02.0 *)
+
+val output : out_channel -> bytes -> int -> int -> unit
+(** [output oc buf pos len] writes [len] characters from byte sequence [buf],
+ starting at offset [pos], to the given output channel [oc].
+ Raise [Invalid_argument "output"] if [pos] and [len] do not
+ designate a valid range of [buf]. *)
+
+val output_substring : out_channel -> string -> int -> int -> unit
+(** Same as [output] but take a string as argument instead of
+ a byte sequence.
+ @since 4.02.0 *)
+
+val output_byte : out_channel -> int -> unit
+(** Write one 8-bit integer (as the single character with that code)
+ on the given output channel. The given integer is taken modulo
+ 256. *)
+
+val output_binary_int : out_channel -> int -> unit
+(** Write one integer in binary format (4 bytes, big-endian)
+ on the given output channel.
+ The given integer is taken modulo 2{^32}.
+ The only reliable way to read it back is through the
+ {!Pervasives.input_binary_int} function. The format is compatible across
+ all machines for a given version of OCaml. *)
+
+val output_value : out_channel -> 'a -> unit
+(** Write the representation of a structured value of any type
+ to a channel. Circularities and sharing inside the value
+ are detected and preserved. The object can be read back,
+ by the function {!Pervasives.input_value}. See the description of module
+ {!Marshal} for more information. {!Pervasives.output_value} is equivalent
+ to {!Marshal.to_channel} with an empty list of flags. *)
+
+val seek_out : out_channel -> int -> unit
+(** [seek_out chan pos] sets the current writing position to [pos]
+ for channel [chan]. This works only for regular files. On
+ files of other kinds (such as terminals, pipes and sockets),
+ the behavior is unspecified. *)
+
+val pos_out : out_channel -> int
+(** Return the current writing position for the given channel. Does
+ not work on channels opened with the [Open_append] flag (returns
+ unspecified results). *)
+
+val out_channel_length : out_channel -> int
+(** Return the size (number of characters) of the regular file
+ on which the given channel is opened. If the channel is opened
+ on a file that is not a regular file, the result is meaningless. *)
+
+val close_out : out_channel -> unit
+(** Close the given channel, flushing all buffered write operations.
+ Output functions raise a [Sys_error] exception when they are
+ applied to a closed output channel, except [close_out] and [flush],
+ which do nothing when applied to an already closed channel.
+ Note that [close_out] may raise [Sys_error] if the operating
+ system signals an error when flushing or closing. *)
+
+val close_out_noerr : out_channel -> unit
+(** Same as [close_out], but ignore all errors. *)
+
+val set_binary_mode_out : out_channel -> bool -> unit
+(** [set_binary_mode_out oc true] sets the channel [oc] to binary
+ mode: no translations take place during output.
+ [set_binary_mode_out oc false] sets the channel [oc] to text
+ mode: depending on the operating system, some translations
+ may take place during output. For instance, under Windows,
+ end-of-lines will be translated from [\n] to [\r\n].
+ This function has no effect under operating systems that
+ do not distinguish between text mode and binary mode. *)
+
+
+(** {2 General input functions} *)
+
+val open_in : string -> in_channel
+(** Open the named file for reading, and return a new input channel
+ on that file, positioned at the beginning of the file. *)
+
+val open_in_bin : string -> in_channel
+(** Same as {!Pervasives.open_in}, but the file is opened in binary mode,
+ so that no translation takes place during reads. On operating
+ systems that do not distinguish between text mode and binary
+ mode, this function behaves like {!Pervasives.open_in}. *)
+
+val open_in_gen : open_flag list -> int -> string -> in_channel
+(** [open_in_gen mode perm filename] opens the named file for reading,
+ as described above. The extra arguments
+ [mode] and [perm] specify the opening mode and file permissions.
+ {!Pervasives.open_in} and {!Pervasives.open_in_bin} are special
+ cases of this function. *)
+
+val input_char : in_channel -> char
+(** Read one character from the given input channel.
+ Raise [End_of_file] if there are no more characters to read. *)
+
+val input_line : in_channel -> string
+(** Read characters from the given input channel, until a
+ newline character is encountered. Return the string of
+ all characters read, without the newline character at the end.
+ Raise [End_of_file] if the end of the file is reached
+ at the beginning of line. *)
+
+val input : in_channel -> bytes -> int -> int -> int
+(** [input ic buf pos len] reads up to [len] characters from
+ the given channel [ic], storing them in byte sequence [buf], starting at
+ character number [pos].
+ It returns the actual number of characters read, between 0 and
+ [len] (inclusive).
+ A return value of 0 means that the end of file was reached.
+ A return value between 0 and [len] exclusive means that
+ not all requested [len] characters were read, either because
+ no more characters were available at that time, or because
+ the implementation found it convenient to do a partial read;
+ [input] must be called again to read the remaining characters,
+ if desired. (See also {!Pervasives.really_input} for reading
+ exactly [len] characters.)
+ Exception [Invalid_argument "input"] is raised if [pos] and [len]
+ do not designate a valid range of [buf]. *)
+
+val really_input : in_channel -> bytes -> int -> int -> unit
+(** [really_input ic buf pos len] reads [len] characters from channel [ic],
+ storing them in byte sequence [buf], starting at character number [pos].
+ Raise [End_of_file] if the end of file is reached before [len]
+ characters have been read.
+ Raise [Invalid_argument "really_input"] if
+ [pos] and [len] do not designate a valid range of [buf]. *)
+
+val really_input_string : in_channel -> int -> string
+(** [really_input_string ic len] reads [len] characters from channel [ic]
+ and returns them in a new string.
+ Raise [End_of_file] if the end of file is reached before [len]
+ characters have been read.
+ @since 4.02.0 *)
+
+val input_byte : in_channel -> int
+(** Same as {!Pervasives.input_char}, but return the 8-bit integer representing
+ the character.
+ Raise [End_of_file] if an end of file was reached. *)
+
+val input_binary_int : in_channel -> int
+(** Read an integer encoded in binary format (4 bytes, big-endian)
+ from the given input channel. See {!Pervasives.output_binary_int}.
+ Raise [End_of_file] if an end of file was reached while reading the
+ integer. *)
+
+val input_value : in_channel -> 'a
+(** Read the representation of a structured value, as produced
+ by {!Pervasives.output_value}, and return the corresponding value.
+ This function is identical to {!Marshal.from_channel};
+ see the description of module {!Marshal} for more information,
+ in particular concerning the lack of type safety. *)
+
+val seek_in : in_channel -> int -> unit
+(** [seek_in chan pos] sets the current reading position to [pos]
+ for channel [chan]. This works only for regular files. On
+ files of other kinds, the behavior is unspecified. *)
+
+val pos_in : in_channel -> int
+(** Return the current reading position for the given channel. *)
+
+val in_channel_length : in_channel -> int
+(** Return the size (number of characters) of the regular file
+ on which the given channel is opened. If the channel is opened
+ on a file that is not a regular file, the result is meaningless.
+ The returned size does not take into account the end-of-line
+ translations that can be performed when reading from a channel
+ opened in text mode. *)
+
+val close_in : in_channel -> unit
+(** Close the given channel. Input functions raise a [Sys_error]
+ exception when they are applied to a closed input channel,
+ except [close_in], which does nothing when applied to an already
+ closed channel. *)
+
+val close_in_noerr : in_channel -> unit
+(** Same as [close_in], but ignore all errors. *)
+
+val set_binary_mode_in : in_channel -> bool -> unit
+(** [set_binary_mode_in ic true] sets the channel [ic] to binary
+ mode: no translations take place during input.
+ [set_binary_mode_out ic false] sets the channel [ic] to text
+ mode: depending on the operating system, some translations
+ may take place during input. For instance, under Windows,
+ end-of-lines will be translated from [\r\n] to [\n].
+ This function has no effect under operating systems that
+ do not distinguish between text mode and binary mode. *)
+
+
+(** {2 Operations on large files} *)
+
+module LargeFile :
+ sig
+ val seek_out : out_channel -> int64 -> unit
+ val pos_out : out_channel -> int64
+ val out_channel_length : out_channel -> int64
+ val seek_in : in_channel -> int64 -> unit
+ val pos_in : in_channel -> int64
+ val in_channel_length : in_channel -> int64
+ end
+(** Operations on large files.
+ This sub-module provides 64-bit variants of the channel functions
+ that manipulate file positions and file sizes. By representing
+ positions and sizes by 64-bit integers (type [int64]) instead of
+ regular integers (type [int]), these alternate functions allow
+ operating on files whose sizes are greater than [max_int]. *)
+
+
+(** {1 References} *)
+
+type 'a ref = { mutable contents : 'a }
+(** The type of references (mutable indirection cells) containing
+ a value of type ['a]. *)
+
+external ref : 'a -> 'a ref = "%makemutable"
+(** Return a fresh reference containing the given value. *)
+
+external ( ! ) : 'a ref -> 'a = "%field0"
+(** [!r] returns the current contents of reference [r].
+ Equivalent to [fun r -> r.contents].
+ Unary operator at precedence level 11/11.*)
+
+external ( := ) : 'a ref -> 'a -> unit = "%setfield0"
+(** [r := a] stores the value of [a] in reference [r].
+ Equivalent to [fun r v -> r.contents <- v].
+ Right-associative operator at precedence level 1/11. *)
+
+external incr : int ref -> unit = "%incr"
+(** Increment the integer contained in the given reference.
+ Equivalent to [fun r -> r := succ !r]. *)
+
+external decr : int ref -> unit = "%decr"
+(** Decrement the integer contained in the given reference.
+ Equivalent to [fun r -> r := pred !r]. *)
+
+(** {1 Result type} *)
+
+(** @since 4.03.0 *)
+type ('a,'b) result = Ok of 'a | Error of 'b
+
+(** {1 Operations on format strings} *)
+
+(** Format strings are character strings with special lexical conventions
+ that defines the functionality of formatted input/output functions. Format
+ strings are used to read data with formatted input functions from module
+ {!Scanf} and to print data with formatted output functions from modules
+ {!Printf} and {!Format}.
+
+ Format strings are made of three kinds of entities:
+ - {e conversions specifications}, introduced by the special character ['%']
+ followed by one or more characters specifying what kind of argument to
+ read or print,
+ - {e formatting indications}, introduced by the special character ['@']
+ followed by one or more characters specifying how to read or print the
+ argument,
+ - {e plain characters} that are regular characters with usual lexical
+ conventions. Plain characters specify string literals to be read in the
+ input or printed in the output.
+
+ There is an additional lexical rule to escape the special characters ['%']
+ and ['@'] in format strings: if a special character follows a ['%']
+ character, it is treated as a plain character. In other words, ["%%"] is
+ considered as a plain ['%'] and ["%@"] as a plain ['@'].
+
+ For more information about conversion specifications and formatting
+ indications available, read the documentation of modules {!Scanf},
+ {!Printf} and {!Format}.
+*)
+
+(** Format strings have a general and highly polymorphic type
+ [('a, 'b, 'c, 'd, 'e, 'f) format6].
+ The two simplified types, [format] and [format4] below are
+ included for backward compatibility with earlier releases of
+ OCaml.
+
+ The meaning of format string type parameters is as follows:
+
+ - ['a] is the type of the parameters of the format for formatted output
+ functions ([printf]-style functions);
+ ['a] is the type of the values read by the format for formatted input
+ functions ([scanf]-style functions).
+
+ - ['b] is the type of input source for formatted input functions and the
+ type of output target for formatted output functions.
+ For [printf]-style functions from module {!Printf}, ['b] is typically
+ [out_channel];
+ for [printf]-style functions from module {!Format}, ['b] is typically
+ {!Format.formatter};
+ for [scanf]-style functions from module {!Scanf}, ['b] is typically
+ {!Scanf.Scanning.in_channel}.
+
+ Type argument ['b] is also the type of the first argument given to
+ user's defined printing functions for [%a] and [%t] conversions,
+ and user's defined reading functions for [%r] conversion.
+
+ - ['c] is the type of the result of the [%a] and [%t] printing
+ functions, and also the type of the argument transmitted to the
+ first argument of [kprintf]-style functions or to the
+ [kscanf]-style functions.
+
+ - ['d] is the type of parameters for the [scanf]-style functions.
+
+ - ['e] is the type of the receiver function for the [scanf]-style functions.
+
+ - ['f] is the final result type of a formatted input/output function
+ invocation: for the [printf]-style functions, it is typically [unit];
+ for the [scanf]-style functions, it is typically the result type of the
+ receiver function.
+*)
+
+type ('a, 'b, 'c, 'd, 'e, 'f) format6 =
+ ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
+
+type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
+
+type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
+
+val string_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string
+(** Converts a format string into a string. *)
+
+external format_of_string :
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
+(** [format_of_string s] returns a format string read from the string
+ literal [s].
+ Note: [format_of_string] can not convert a string argument that is not a
+ literal. If you need this functionality, use the more general
+ {!Scanf.format_from_string} function.
+*)
+
+val ( ^^ ) :
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+ ('f, 'b, 'c, 'e, 'g, 'h) format6 ->
+ ('a, 'b, 'c, 'd, 'g, 'h) format6
+(** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a
+ format string that behaves as the concatenation of format strings [f1] and
+ [f2]: in case of formatted output, it accepts arguments from [f1], then
+ arguments from [f2]; in case of formatted input, it returns results from
+ [f1], then results from [f2].
+ Right-associative operator at precedence level 5/11. *)
+
+
+(** {1 Program termination} *)
+
+val exit : int -> 'a
+(** Terminate the process, returning the given status code
+ to the operating system: usually 0 to indicate no errors,
+ and a small positive integer to indicate failure.
+ All open output channels are flushed with [flush_all].
+ An implicit [exit 0] is performed each time a program
+ terminates normally. An implicit [exit 2] is performed if the program
+ terminates early because of an uncaught exception. *)
+
+val at_exit : (unit -> unit) -> unit
+(** Register the given function to be called at program termination
+ time. The functions registered with [at_exit] will be called when
+ the program does any of the following:
+ - executes {!Pervasives.exit}
+ - terminates, either normally or because of an uncaught
+ exception
+ - executes the C function [caml_shutdown].
+ The functions are called in 'last in, first out' order: the
+ function most recently added with [at_exit] is called first. *)
+
+(**/**)
+
+(* The following is for system use only. Do not call directly. *)
+
+val valid_float_lexem : string -> string
+
+val unsafe_really_input : in_channel -> bytes -> int -> int -> unit
+
+val do_at_exit : unit -> unit
+end
+
+include module type of struct include Pervasives end
+
+(*MODULE_ALIASES*)
+module Arg = Arg
+module Array = Array
+module ArrayLabels = ArrayLabels
+module Bigarray = Bigarray
+module Buffer = Buffer
+module Bytes = Bytes
+module BytesLabels = BytesLabels
+module Callback = Callback
+module Char = Char
+module Complex = Complex
+module Digest = Digest
+module Ephemeron = Ephemeron
+module Filename = Filename
+module Float = Float
+module Format = Format
+module Gc = Gc
+module Genlex = Genlex
+module Hashtbl = Hashtbl
+module Int32 = Int32
+module Int64 = Int64
+module Lazy = Lazy
+module Lexing = Lexing
+module List = List
+module ListLabels = ListLabels
+module Map = Map
+module Marshal = Marshal
+module MoreLabels = MoreLabels
+module Nativeint = Nativeint
+module Obj = Obj
+module Oo = Oo
+module Parsing = Parsing
+module Printexc = Printexc
+module Printf = Printf
+module Queue = Queue
+module Random = Random
+module Scanf = Scanf
+module Seq = Seq
+module Set = Set
+module Sort = Sort
+module Spacetime = Spacetime
+module Stack = Stack
+module StdLabels = StdLabels
+module Stream = Stream
+module String = String
+module StringLabels = StringLabels
+module Sys = Sys
+module Uchar = Uchar
+module Weak = Weak
match s.data with
Scons (_, d) -> s.count <- (succ s.count); s.data <- d
| Sgen ({curr = Some _} as g) -> s.count <- (succ s.count); g.curr <- None
- | Sbuffio b -> s.count <- (succ s.count); b.ind <- succ b.ind
+ | Sbuffio b ->
+ if b.ind >= b.len then fill_buff b;
+ if b.len == 0 then s.data <- Sempty
+ else (s.count <- (succ s.count); b.ind <- succ b.ind)
| _ ->
match peek_data s with
None -> ()
else s
let escaped s =
- let rec needs_escape i =
- if i >= length s then false else
+ let rec escape_if_needed s n i =
+ if i >= n then s else
match unsafe_get s i with
- | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> true
- | ' ' .. '~' -> needs_escape (i+1)
- | _ -> true
+ | '\"' | '\\' | '\000'..'\031' | '\127'.. '\255' -> bts (B.escaped (bos s))
+ | _ -> escape_if_needed s n (i+1)
in
- if needs_escape 0 then
- bts (B.escaped (bos s))
- else
- s
+ escape_if_needed s (length s) 0
(* duplicated in bytes.ml *)
let rec index_rec s lim i c =
B.capitalize (bos s) |> bts
let uncapitalize s =
B.uncapitalize (bos s) |> bts
+
+(** {6 Iterators} *)
+
+let to_seq s = bos s |> B.to_seq
+
+let to_seqi s = bos s |> B.to_seqi
+
+let of_seq g = B.of_seq g |> bts
+
@since 4.04.0
*)
+(** {6 Iterators} *)
+
+val to_seq : t -> char Seq.t
+(** Iterate on the string, in increasing index order. Modifications of the
+ string during iteration will be reflected in the iterator.
+ @since 4.07 *)
+
+val to_seqi : t -> (int * char) Seq.t
+(** Iterate on the string, in increasing order, yielding indices along chars
+ @since 4.07 *)
+
+val of_seq : char Seq.t -> t
+(** Create a string from the generator
+ @since 4.07 *)
+
(**/**)
(* The following is for system use only. Do not call directly. *)
@since 4.05.0
*)
+(** {6 Iterators} *)
+
+val to_seq : t -> char Seq.t
+(** Iterate on the string, in increasing index order. Modifications of the
+ string during iteration will be reflected in the iterator.
+ @since 4.07 *)
+
+val to_seqi : t -> (int * char) Seq.t
+(** Iterate on the string, in increasing order, yielding indices along chars
+ @since 4.07 *)
+
+val of_seq : char Seq.t -> t
+(** Create a string from the generator
+ @since 4.07 *)
+
(**/**)
(* The following is for system use only. Do not call directly. *)
given to the program. *)
val executable_name : string
-(** The name of the file containing the executable currently running. *)
+(** The name of the file containing the executable currently running.
+ This name may be absolute or relative to the current directory, depending
+ on the platform and whether the program was compiled to bytecode or a native
+ executable. *)
external file_exists : string -> bool = "caml_sys_file_exists"
(** Test if a file with the given name exists. *)
val word_size : int
(** Size of one word on the machine currently executing the OCaml
- program, in bits: 32 or 64. *)
+ program, in bits: 32 or 64. *)
val int_size : int
-(** Size of an int. It is 31 bits (resp. 63 bits) when using the
- OCaml compiler on a 32 bits (resp. 64 bits) platform. It may
- differ for other compilers, e.g. it is 32 bits when compiling to
- JavaScript.
+(** Size of [int], in bits. It is 31 (resp. 63) when using OCaml on a
+ 32-bit (resp. 64-bit) platform. It may differ for other implementations,
+ e.g. it can be 32 bits when compiling to JavaScript.
@since 4.03.0 *)
val big_endian : bool
type t
(** The type for Unicode characters.
- A value of this type represents an Unicode
+ A value of this type represents a Unicode
{{:http://unicode.org/glossary/#unicode_scalar_value}scalar
value} which is an integer in the ranges [0x0000]...[0xD7FF] or
[0xE000]...[0x10FFFF]. *)
@raise Invalid_argument if [u] is {!min}. *)
val is_valid : int -> bool
-(** [is_valid n] is [true] iff [n] is an Unicode scalar value
+(** [is_valid n] is [true] iff [n] is a Unicode scalar value
(i.e. in the ranges [0x0000]...[0xD7FF] or [0xE000]...[0x10FFFF]).*)
val of_int : int -> t
-(** [of_int i] is [i] as an Unicode character.
+(** [of_int i] is [i] as a Unicode character.
@raise Invalid_argument if [i] does not satisfy {!is_valid}. *)
(** [is_char u] is [true] iff [u] is a latin1 OCaml character. *)
val of_char : char -> t
-(** [of_char c] is [c] as an Unicode character. *)
+(** [of_char c] is [c] as a Unicode character. *)
val to_char : t -> char
(** [to_char u] is [u] as an OCaml latin1 character.
&& echo --no-print-directory`
FIND=find
-include ../config/Makefile
+TOPDIR := ..
+include $(TOPDIR)/Makefile.tools
ifeq "$(UNIX_OR_WIN32)" "unix"
ifeq "$(SYSTEM)" "cygwin"
failstamp := failure.stamp
+TESTLOG ?= _log
+
ocamltest_directory := ../ocamltest
ocamltest_program := $(or \
$(wildcard $(ocamltest_directory)/ocamltest.opt$(EXE)),\
$(wildcard $(ocamltest_directory)/ocamltest$(EXE)))
-ocamltest := $(FLEXLINK_PREFIX) $(ocamltest_program)
+ocamltest := $(FLEXLINK_PREFIX) SORT=$(SORT) $(ocamltest_program)
.PHONY: default
default:
.PHONY: all
all:
- @rm -f _log
+ @rm -f $(TESTLOG)
@$(MAKE) $(NO_PRINT) legacy-without-report
@$(MAKE) $(NO_PRINT) new-without-report
@$(MAKE) $(NO_PRINT) report
.PHONY: legacy
legacy:
- @rm -f _log
+ @rm -f $(TESTLOG)
@$(MAKE) $(NO_PRINT) legacy-without-report
@$(MAKE) $(NO_PRINT) report
.PHONY: legacy-without-report
legacy-without-report: lib tools
@for dir in tests/*; do \
- $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \
- done 2>&1 | tee -a _log
+ $(MAKE) $(NO_PRINT) exec-one DIR=$$dir LEGACY=y; \
+ done 2>&1 | tee -a $(TESTLOG)
@$(MAKE) $(NO_PRINT) retries
.PHONY: new
new:
- @rm -f _log
+ @rm -f $(TESTLOG)
@$(MAKE) $(NO_PRINT) new-without-report
@$(MAKE) $(NO_PRINT) report
@(for file in `$(find) tests -name ocamltests`; do \
dir=`dirname $$file`; \
echo Running tests from \'$$dir\' ... ; \
- (IFS=$$(printf "\r\n"); while read testfile; do \
- TERM=dumb OCAMLRUNPARAM= \
- $(ocamltest) $$dir/$$testfile || \
- touch $(failstamp); \
- done < $$file) || touch $(failstamp); \
- done || touch $(failstamp)) 2>&1 | tee -a _log
+ $(MAKE) exec-ocamltest DIR=$$dir \
+ OCAMLTESTENV="" OCAMLTESTFLAGS=""; \
+ done || touch $(failstamp)) 2>&1 | tee -a $(TESTLOG)
@if [ -f $(failstamp) ]; then rm $(failstamp); exit 1; fi
.PHONY: all-%
all-%: lib tools
@for dir in tests/$**; do \
$(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \
- done 2>&1 | tee _log
+ done 2>&1 | tee $(TESTLOG)
@$(MAKE) $(NO_PRINT) retries
@$(MAKE) report
@for dir in tests/$**; do echo $$dir; done \
| parallel --gnu --no-notice --keep-order \
"$(MAKE) $(NO_PRINT) exec-one DIR={} 2>&1" \
- | tee _log
+ | tee $(TESTLOG)
@$(MAKE) $(NO_PRINT) retries
@$(MAKE) report
fi
@while read LINE; do \
$(MAKE) $(NO_PRINT) exec-one DIR=$$LINE; \
- done <$(FILE) 2>&1 | tee _log
+ done <$(FILE) 2>&1 | tee $(TESTLOG)
@$(MAKE) $(NO_PRINT) retries
@$(MAKE) report
exit 1; \
fi
@$(MAKE) $(NO_PRINT) exec-one DIR=$(DIR)
+ @if [ -f $(failstamp) ]; then rm $(failstamp); exit 1; fi
.PHONY: exec-one
exec-one:
echo "Running tests from '$$DIR' ..."; \
cd $(DIR) && \
$(MAKE) TERM=dumb BASEDIR=$(BASEDIR) || echo '=> unexpected error'; \
+ elif [ -f $(DIR)/ocamltests ] && [ -z $(LEGACY) ] ; then \
+ echo "Running tests from '$$DIR' ..."; \
+ $(MAKE) exec-ocamltest DIR=$(DIR) \
+ OCAMLTESTENV="OCAMLTESTDIR=$(shell $(CYGPATH) $(BASEDIR)/$(DIR)/_ocamltest)" \
+ OCAMLTESTFLAGS=""; \
fi
+.PHONY: exec-ocamltest
+exec-ocamltest:
+ @if [ -z "$(DIR)" ]; then exit 1; fi
+ @if [ ! -d "$(DIR)" ]; then exit 1; fi
+ @file=$(DIR)/ocamltests; \
+ (IFS=$$(printf "\r\n"); while read testfile; do \
+ TERM=dumb $(OCAMLTESTENV) \
+ $(ocamltest) $(OCAMLTESTFLAGS) $(DIR)/$$testfile || \
+ touch $(failstamp); \
+ done < $$file) || touch $(failstamp)
+
.PHONY: clean-one
clean-one:
@if [ ! -f $(DIR)/Makefile ]; then \
echo "Directory '$(DIR)' does not exist."; \
exit 1; \
fi
- @cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) promote
+ @if [ -f $(DIR)/ocamltests ]; then \
+ $(MAKE) exec-ocamltest DIR=$(DIR) \
+ OCAMLTESTENV="OCAMLTESTDIR=$(shell $(CYGPATH) $(BASEDIR)/$(DIR)/_ocamltest)" \
+ OCAMLTESTFLAGS="-promote"; \
+ else \
+ cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) promote; \
+ fi
.PHONY: lib
lib:
.PHONY: report
report:
- @if [ ! -f _log ]; then echo "No '_log' file."; exit 1; fi
- @awk -f makefiles/summarize.awk <_log
+ @if [ ! -f $(TESTLOG) ]; then echo "No $(TESTLOG) file."; exit 1; fi
+ @awk -f makefiles/summarize.awk < $(TESTLOG)
.PHONY: retry-list
retry-list:
@while read LINE; do \
if [ -n "$$LINE" ] ; then \
- echo re-ran $$LINE>>_log; \
+ echo re-ran $$LINE>> $(TESTLOG); \
$(MAKE) $(NO_PRINT) clean-one DIR=$$LINE; \
- $(MAKE) $(NO_PRINT) exec-one DIR=$$LINE 2>&1 | tee -a _log ; \
+ $(MAKE) $(NO_PRINT) exec-one DIR=$$LINE 2>&1 | tee -a $(TESTLOG) ; \
fi \
done <_retries;
@$(MAKE) $(NO_PRINT) retries
.PHONY: retries
retries:
@awk -v retries=1 -v max_retries=$(MAX_TESTSUITE_DIR_RETRIES) \
- -f makefiles/summarize.awk <_log >_retries
+ -f makefiles/summarize.awk < $(TESTLOG) > _retries
@test `cat _retries | wc -l` -eq 0 || $(MAKE) $(NO_PRINT) retry-list
@rm -f _retries
BASEDIR=../..
#MODULES=
MAIN_MODULE=sorts
-ADD_COMPFLAGS=-thread
+ADD_COMPFLAGS=-I +threads
LIBRARIES=unix threads graphics
include $(BASEDIR)/makefiles/Makefile.one
include ../makefiles/Makefile.common
.PHONY: compile-targets
-compile-targets: testing.cmi testing.cma
+compile-targets: testing.cmi testing.cma lib.cmo
@if $(BYTECODE_ONLY); then : ; else \
$(MAKE) testing.cmxa; \
fi
--- /dev/null
+external raise : exn -> 'a = "%raise"
+
+external not : bool -> bool = "%boolnot"
+
+external (=) : 'a -> 'a -> bool = "%equal"
+external (<>) : 'a -> 'a -> bool = "%notequal"
+external (<) : 'a -> 'a -> bool = "%lessthan"
+external (>) : 'a -> 'a -> bool = "%greaterthan"
+external (<=) : 'a -> 'a -> bool = "%lessequal"
+external (>=) : 'a -> 'a -> bool = "%greaterequal"
+
+external (~-) : int -> int = "%negint"
+external (+) : int -> int -> int = "%addint"
+external (-) : int -> int -> int = "%subint"
+external ( * ) : int -> int -> int = "%mulint"
+external (/) : int -> int -> int = "%divint"
+external (mod) : int -> int -> int = "%modint"
+
+external (land) : int -> int -> int = "%andint"
+external (lor) : int -> int -> int = "%orint"
+external (lxor) : int -> int -> int = "%xorint"
+external (lsl) : int -> int -> int = "%lslint"
+external (lsr) : int -> int -> int = "%lsrint"
+external (asr) : int -> int -> int = "%asrint"
+
+external ignore : 'a -> unit = "%ignore"
+
+type 'a ref = { mutable contents: 'a }
+external ref : 'a -> 'a ref = "%makemutable"
+external (!) : 'a ref -> 'a = "%field0"
+external (:=) : 'a ref -> 'a -> unit = "%setfield0"
+external incr : int ref -> unit = "%incr"
+external decr : int ref -> unit = "%decr"
+
+type 'a option = None | Some of 'a
+
+type 'a weak_t;;
+external weak_create: int -> 'a weak_t = "caml_weak_create";;
+external weak_set : 'a weak_t -> int -> 'a option -> unit = "caml_weak_set";;
+external weak_get: 'a weak_t -> int -> 'a option = "caml_weak_get";;
+
+let x = 42;;
default:
@for file in *.ml; do \
printf " ... testing '$$file':"; \
- TERM=dumb $(EXPECT_TEST) -repo-root $(OTOPDIR) $$file && \
- TERM=dumb $(EXPECT_TEST) -repo-root $(OTOPDIR) -principal \
+ TERM=dumb $(EXPECT_TEST) $(EXPECT_FLAGS) -repo-root $(OTOPDIR) $$file && \
+ TERM=dumb $(EXPECT_TEST) $(EXPECT_FLAGS) -repo-root $(OTOPDIR) -principal \
$$file.corrected && \
mv $$file.corrected.corrected $$file.corrected && \
$(DIFF) $$file $$file.corrected && \
echo " => passed" || echo " => failed"; \
done
+# Builds everything needed to run an expect test
+.PHONY: deps
+deps:
+ @$(MAKE) -C $(OTOPDIR) coldstart ocaml ocamlc
+ @$(MAKE) -C $(OTOPDIR)/testsuite/tools expect_test$(EXE)
+
.PHONY: promote
promote:
@for file in *.corrected; do \
+++ /dev/null
-BASEDIR=../..
-
-default:
- @printf " ... testing 'afl_instrumentation':"
- @if ! which afl-showmap > /dev/null; then \
- echo " => skipped (afl-showmap unavailable)"; \
- else \
- if OCAMLOPT='$(OCAMLOPT)' ./test.sh > /dev/null; then \
- echo " => passed"; \
- else \
- echo " => failed"; \
- fi \
- fi
-
-include $(BASEDIR)/makefiles/Makefile.common
-
-clean: defaultclean
--- /dev/null
+(* TEST (* Just a test-driver *)
+ * native-compiler
+ ** no-afl-instrument
+ *** script
+ script = "sh ${test_source_directory}/has-afl-showmap.sh"
+ files = "harness.ml test.ml"
+ **** setup-ocamlopt.byte-build-env
+ ***** ocamlopt.byte
+ module = "test.ml"
+ flags = "-afl-instrument"
+ ****** ocamlopt.byte
+ module = ""
+ program = "${test_build_directory}/test"
+ flags = "-afl-inst-ratio 0"
+ all_modules = "test.cmx harness.ml"
+ ******* run
+*)
--- /dev/null
+#!/bin/bash
+
+set -e
+
+output="${program}".output
+exec > ${output} 2>&1
+
+NTESTS=`./test len`
+failures=''
+echo "running $NTESTS tests..."
+for t in `seq 1 $NTESTS`; do
+ printf "%14s: " `./test name $t`
+ # when run twice, the instrumentation output should double
+ afl-showmap -q -o output-1 -- ./test 1 $t
+ afl-showmap -q -o output-2 -- ./test 2 $t
+ # see afl-showmap.c for what the numbers mean
+ cat output-1 | sed '
+ s/:6/:7/; s/:5/:6/;
+ s/:4/:5/; s/:3/:4/;
+ s/:2/:4/; s/:1/:2/;
+ ' > output-2-predicted
+ if cmp -s output-2-predicted output-2; then
+ echo "passed."
+ else
+ echo "failed:"
+ paste output-2 output-1
+ failures=1
+ fi
+done
+
+if [ -z "$failures" ]; then
+ echo "all tests passed";
+ exit ${TEST_PASS}
+else
+ exit ${TEST_FAIL};
+fi
--- /dev/null
+#!/bin/sh
+if ! which afl-showmap > /dev/null 2>&1; then
+ echo "afl-showmap not available" > ${ocamltest_response}
+ exit ${TEST_SKIP}
+else
+ exit ${TEST_PASS}
+fi
--- /dev/null
+afltest.ml
+++ /dev/null
-#!/bin/bash
-
-set -e
-
-$OCAMLOPT -c -afl-instrument test.ml
-$OCAMLOPT -afl-inst-ratio 0 test.cmx harness.ml -o test
-
-NTESTS=`./test len`
-failures=''
-echo "running $NTESTS tests..."
-for t in `seq 1 $NTESTS`; do
- printf "%14s: " `./test name $t`
- # when run twice, the instrumentation output should double
- afl-showmap -q -o output-1 -- ./test 1 $t
- afl-showmap -q -o output-2 -- ./test 2 $t
- # see afl-showmap.c for what the numbers mean
- cat output-1 | sed '
- s/:6/:7/; s/:5/:6/;
- s/:4/:5/; s/:3/:4/;
- s/:2/:4/; s/:1/:2/;
- ' > output-2-predicted
- if cmp -s output-2-predicted output-2; then
- echo "passed."
- else
- echo "failed:"
- paste output-2 output-1
- failures=1
- fi
-done
-
-if [ -z "$failures" ]; then echo "all tests passed"; else exit 1; fi
-
-rm -f {test,harness}.{cmi,cmx,o} test output-{1,2,2-predicted}
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-
-include $(BASEDIR)/../config/Makefile
-
-INCLUDES=\
- -I $(OTOPDIR)/parsing \
- -I $(OTOPDIR)/utils \
- -I $(OTOPDIR)/typing \
- -I $(OTOPDIR)/middle_end \
- -I $(OTOPDIR)/bytecomp \
- -I $(OTOPDIR)/asmcomp
-
-OTHEROBJS=\
- $(OTOPDIR)/compilerlibs/ocamlcommon.cma \
- $(OTOPDIR)/compilerlibs/ocamloptcomp.cma
-
-OBJS=parsecmmaux.cmo parsecmm.cmo lexcmm.cmo
-
-ADD_COMPFLAGS=$(INCLUDES) -w -40 -g
-
-default:
- @if $(BYTECODE_ONLY) || $(SKIP) ; then $(MAKE) skips ; else \
- $(MAKE) all; \
- fi
-
-all:
- @$(MAKE) arch codegen
- @$(MAKE) tests
-
-main.cmo: parsecmm.cmo
-
-codegen: parsecmm.ml lexcmm.ml $(OBJS:.cmo=.cmi) $(OBJS) main.cmo
- @$(OCAMLC) $(LINKFLAGS) -o codegen $(OTHEROBJS) $(OBJS) main.cmo
-
-parsecmm.mli parsecmm.ml: parsecmm.mly
- @$(OCAMLYACC) -q parsecmm.mly
-
-lexcmm.ml: lexcmm.mll
- @$(OCAMLLEX) -q lexcmm.mll
-
-MLCASES=optargs staticalloc bind_tuples is_static register_typing \
- register_typing_switch
-ARGS_optargs=-g
-ARGS_is_static=-I $(OTOPDIR)/byterun is_in_static_data.c
-MLCASES_FLAMBDA=is_static_flambda unrolling_flambda unrolling_flambda2
-MLCASES_FLAMBDA_FLOAT=static_float_array_flambda \
- static_float_array_flambda_opaque
-ARGS_is_static_flambda=\
- -I $(OTOPDIR)/byterun is_in_static_data.c is_static_flambda_dep.ml
-ARGS_static_float_array_flambda=\
- -I $(OTOPDIR)/byterun is_in_static_data.c simple_float_const.ml
-ARGS_static_float_array_flambda_opaque=\
- -I $(OTOPDIR)/byterun is_in_static_data.c -opaque simple_float_const_opaque.ml
-
-CASES=fib tak quicksort quicksort2 soli \
- arith checkbound tagged-fib tagged-integr tagged-quicksort tagged-tak \
- catch-try catch-rec even-odd even-odd-spill pgcd
-ARGS_fib=-DINT_INT -DFUN=fib main.c
-ARGS_tak=-DUNIT_INT -DFUN=takmain main.c
-ARGS_quicksort=-DSORT -DFUN=quicksort main.c
-ARGS_quicksort2=-DSORT -DFUN=quicksort main.c
-ARGS_soli=-DUNIT_INT -DFUN=solitaire main.c
-ARGS_integr=-DINT_FLOAT -DFUN=test main.c
-ARGS_arith=mainarith.c
-ARGS_checkbound=-DCHECKBOUND main.c
-ARGS_tagged-fib=-DINT_INT -DFUN=fib main.c
-ARGS_tagged-integr=-DINT_FLOAT -DFUN=test main.c
-ARGS_tagged-quicksort=-DSORT -DFUN=quicksort main.c
-ARGS_tagged-tak=-DUNIT_INT -DFUN=takmain main.c
-ARGS_staticalloc=-I $(OTOPDIR)/utils config.cmx
-ARGS_catch-try=-DINT_INT -DFUN=catch_exit main.c
-ARGS_catch-rec=-DINT_INT -DFUN=catch_fact main.c
-ARGS_even-odd=-DINT_INT -DFUN=is_even main.c
-ARGS_even-odd-spill=-DINT_INT -DFUN=is_even main.c
-ARGS_pgcd=-DINT_INT -DFUN=pgcd_30030 main.c
-
-skips:
- @for c in $(CASES) $(MLCASES) $(MLCASES_FLAMBDA) \
- $(MLCASES_FLAMBDA_FLOAT); do \
- echo " ... testing '$$c': => skipped"; \
- done
-
-one_ml:
- @$(OCAMLOPT) $(ARGS_$(NAME)) -o $(NAME).exe $(NAME).ml && \
- ./$(NAME).exe && echo " => passed" || echo " => failed"
-
-one_ml_cond:
- @if $(COND); then \
- $(OCAMLOPT) $(ARGS_$(NAME)) -o $(NAME).exe $(NAME).ml && \
- ./$(NAME).exe && echo " => passed" || echo " => failed"; \
- else \
- echo " => skipped"; \
- fi
-
-one:
- @$(call CCOMP,$(NAME).out $(ARGS_$(NAME)) $(NAME).$(O) $(ARCH).$(O)) \
- && echo " => passed" || echo " => failed"
-
-clean: defaultclean
- @rm -f ./codegen *.out *.out.manifest *.$(O) *.exe
- @rm -f parsecmm.ml parsecmm.mli lexcmm.ml
- @rm -f $(CASES:=.s)
-
-include $(BASEDIR)/makefiles/Makefile.common
-
-ifeq "$(CCOMPTYPE)-$(ARCH)" "msvc-amd64"
-# these tests are not ported to MSVC64 yet
-SKIP=true
-else
-SKIP=false
-endif
-
-ifeq "$(WITH_SPACETIME)" "true"
-# These tests have not been ported for Spacetime
-SKIP=true
-endif
-
-ifeq ($(CCOMPTYPE),msvc)
-CCOMP=set -o pipefail ; $(CC) $(CFLAGS) /Fe$(1) | tail -n +2
-else
-CCOMP=$(CC) $(CFLAGS) -o $(1)
-endif
-tests: $(CASES:=.$(O))
- @for c in $(CASES); do \
- printf " ... testing '$$c':"; \
- $(MAKE) one NAME=$$c; \
- done
- @for c in $(MLCASES); do \
- printf " ... testing '$$c':"; \
- $(MAKE) one_ml NAME=$$c; \
- done
- @for c in $(MLCASES_FLAMBDA); do \
- printf " ... testing '$$c':"; \
- $(MAKE) one_ml_cond NAME=$$c COND=$(FLAMBDA); \
- done
- @for c in $(MLCASES_FLAMBDA_FLOAT); do \
- printf " ... testing '$$c':"; \
- $(MAKE) one_ml_cond NAME=$$c \
- COND='$(FLAMBDA) && $(FLAT_FLOAT_ARRAY)'; \
- done
-
-promote:
-
-arch: $(ARCH).$(O)
-
-i386.obj: i386nt.asm
- @set -o pipefail ; \
- $(ASM) $@ $^ | tail -n +2
+++ /dev/null
-/**************************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. */
-/* */
-/* All rights reserved. This file is distributed under the terms of */
-/* the GNU Lesser General Public License version 2.1, with the */
-/* special exception on linking described in the file LICENSE. */
-/* */
-/**************************************************************************/
-
- .globl call_gen_code
- .ent call_gen_code
-
-call_gen_code:
- lda $sp, -80($sp)
- stq $26, 0($sp)
- stq $9, 8($sp)
- stq $10, 16($sp)
- stq $11, 24($sp)
- stq $12, 32($sp)
- stt $f2, 40($sp)
- stt $f3, 48($sp)
- stt $f4, 56($sp)
- stt $f5, 64($sp)
- mov $16, $27
- mov $17, $16
- mov $18, $17
- mov $19, $18
- mov $20, $19
- jsr ($27)
- ldq $26, 0($sp)
- ldq $9, 8($sp)
- ldq $10, 16($sp)
- ldq $11, 24($sp)
- ldq $12, 32($sp)
- ldt $f2, 40($sp)
- ldt $f3, 48($sp)
- ldt $f4, 56($sp)
- ldt $f5, 64($sp)
- lda $sp, 80($sp)
- ret ($26)
-
- .end call_gen_code
-
- .globl caml_c_call
- .ent caml_c_call
-caml_c_call:
- lda $sp, -16($sp)
- stq $26, 0($sp)
- stq $gp, 8($sp)
- mov $25, $27
- jsr ($25)
- ldq $26, 0($sp)
- ldq $gp, 8($sp)
- lda $sp, 16($sp)
- ret ($26)
-
- .end caml_c_call
+++ /dev/null
-/**************************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2000 Institut National de Recherche en Informatique et */
-/* en Automatique. */
-/* */
-/* All rights reserved. This file is distributed under the terms of */
-/* the GNU Lesser General Public License version 2.1, with the */
-/* special exception on linking described in the file LICENSE. */
-/* */
-/**************************************************************************/
-
-#ifdef SYS_macosx
-#define ALIGN 4
-#else
-#define ALIGN 16
-#endif
-
-#ifdef SYS_macosx
-#define CALL_GEN_CODE _call_gen_code
-#define CAML_C_CALL _caml_c_call
-#define CAML_NEGF_MASK _caml_negf_mask
-#define CAML_ABSF_MASK _caml_absf_mask
-#else
-#define CALL_GEN_CODE call_gen_code
-#define CAML_C_CALL caml_c_call
-#define CAML_NEGF_MASK caml_negf_mask
-#define CAML_ABSF_MASK caml_absf_mask
-#endif
-
- .globl CALL_GEN_CODE
- .align ALIGN
-CALL_GEN_CODE:
- pushq %rbx
- pushq %rbp
- pushq %r12
- pushq %r13
- pushq %r14
- pushq %r15
- movq %rdi, %r10
- movq %rsi, %rax
- movq %rdx, %rbx
- movq %rcx, %rdi
- movq %r8, %rsi
- call *%r10
- popq %r15
- popq %r14
- popq %r13
- popq %r12
- popq %rbp
- popq %rbx
- ret
-
- .globl CAML_C_CALL
- .align ALIGN
-CAML_C_CALL:
- jmp *%rax
-
-#ifdef SYS_macosx
- .literal16
-#elif defined(SYS_mingw64) || defined(SYS_cygwin)
- .section .rodata.cst8
-#else
- .section .rodata.cst8,"aM",@progbits,8
-#endif
- .globl CAML_NEGF_MASK
- .align ALIGN
-CAML_NEGF_MASK:
- .quad 0x8000000000000000, 0
- .globl CAML_ABSF_MASK
- .align ALIGN
-CAML_ABSF_MASK:
- .quad 0x7FFFFFFFFFFFFFFF, 0
-
- .comm young_limit, 8
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(* Regression test for arithmetic instructions *)
-
-(function "testarith" ()
- (let r "R"
- (let d "D"
- (let x (load int "X")
- (let y (load int "Y")
- (let f (load float "F")
- (let g (load float "G")
- (addraset r 0 0)
- (addraset r 1 1)
- (addraset r 2 -1)
- (addraset r 3 256)
- (addraset r 4 65536)
- (addraset r 5 16777216)
- (addraset r 6 -256)
- (addraset r 7 -65536)
- (addraset r 8 -16777216)
-
- (addraset r 9 (+ x y))
- (addraset r 10 (+ x 1))
- (addraset r 11 (+ x -1))
-
- (addraset r 12 (+a "R" 8))
- (addraset r 13 (+a "R" y))
-
- (addraset r 14 (- x y))
- (addraset r 15 (- x 1))
- (addraset r 16 (- x -1))
-
- (addraset r 17 (- "R" 8))
- (addraset r 18 (- "R" y))
-
- (addraset r 19 ( * x 2))
- (addraset r 20 ( * 2 x))
- (addraset r 21 ( * x 16))
- (addraset r 22 ( * 16 x))
- (addraset r 23 ( * x 12345))
- (addraset r 24 ( * 12345 x))
- (addraset r 25 ( * x y))
-
- (addraset r 26 (/ x 2))
- (addraset r 27 (/ x 16))
- (addraset r 28 (/ x 7))
- (addraset r 29 (if (!= y 0) (/ x y) 0))
-
- (addraset r 30 (mod x 2))
- (addraset r 31 (mod x 16))
- (addraset r 32 (if (!= y 0) (mod x y) 0))
-
- (addraset r 33 (and x y))
- (addraset r 34 (and x 3))
- (addraset r 35 (and 3 x))
-
- (addraset r 36 (or x y))
- (addraset r 37 (or x 3))
- (addraset r 38 (or 3 x))
-
- (addraset r 39 (xor x y))
- (addraset r 40 (xor x 3))
- (addraset r 41 (xor 3 x))
-
- (addraset r 42 (<< x y))
- (addraset r 43 (<< x 1))
- (addraset r 44 (<< x 8))
-
- (addraset r 45 (>>u x y))
- (addraset r 46 (>>u x 1))
- (addraset r 47 (>>u x 8))
-
- (addraset r 48 (>>s x y))
- (addraset r 49 (>>s x 1))
- (addraset r 50 (>>s x 8))
-
- (addraset r 51 (== x y))
- (addraset r 52 (!= x y))
- (addraset r 53 (< x y))
- (addraset r 54 (> x y))
- (addraset r 55 (<= x y))
- (addraset r 56 (>= x y))
- (addraset r 57 (== x 1))
- (addraset r 58 (!= x 1))
- (addraset r 59 (< x 1))
- (addraset r 60 (> x 1))
- (addraset r 61 (<= x 1))
- (addraset r 62 (>= x 1))
-
- (addraset r 63 (==a x y))
- (addraset r 64 (!=a x y))
- (addraset r 65 (<a x y))
- (addraset r 66 (>a x y))
- (addraset r 67 (<=a x y))
- (addraset r 68 (>=a x y))
- (addraset r 69 (==a x 1))
- (addraset r 70 (!=a x 1))
- (addraset r 71 (<a x 1))
- (addraset r 72 (>a x 1))
- (addraset r 73 (<=a x 1))
- (addraset r 74 (>=a x 1))
-
- (addraset r 75 (+ x (<< y 1)))
- (addraset r 76 (+ x (<< y 2)))
- (addraset r 77 (+ x (<< y 3)))
- (addraset r 78 (- x (<< y 1)))
- (addraset r 79 (- x (<< y 2)))
- (addraset r 80 (- x (<< y 3)))
-
- (floataset d 0 0.0)
- (floataset d 1 1.0)
- (floataset d 2 -1.0)
- (floataset d 3 (+f f g))
- (floataset d 4 (-f f g))
- (floataset d 5 ( *f f g))
- (floataset d 6 (/f f g))
-
- (floataset d 7 (+f f (+f g 1.0)))
- (floataset d 8 (-f f (+f g 1.0)))
- (floataset d 9 ( *f f (+f g 1.0)))
- (floataset d 10 (/f f (+f g 1.0)))
-
- (floataset d 11 (+f (+f f 1.0) g))
- (floataset d 12 (-f (+f f 1.0) g))
- (floataset d 13 ( *f (+f f 1.0) g))
- (floataset d 14 (/f (+f f 1.0) g))
-
- (floataset d 15 (+f (+f f 1.0) (+f g 1.0)))
- (floataset d 16 (-f (+f f 1.0) (+f g 1.0)))
- (floataset d 17 ( *f (+f f 1.0) (+f g 1.0)))
- (floataset d 18 (/f (+f f 1.0) (+f g 1.0)))
-
- (addraset r 81 (==f f g))
- (addraset r 82 (!=f f g))
- (addraset r 83 (<f f g))
- (addraset r 84 (>f f g))
- (addraset r 85 (<=f f g))
- (addraset r 86 (>=f f g))
-
- (floataset d 19 (floatofint x))
- (addraset r 87 (intoffloat f))
-
- (if (and (>= x 0) (< x y))
- (seq (checkbound y x) (addraset r 88 1))
- (addraset r 88 0))
-
- (if (< 0 y)
- (seq (checkbound y 0) (addraset r 89 1))
- (addraset r 89 0))
-
- (if (< 5 y)
- (seq (checkbound y 5) (addraset r 90 1))
- (addraset r 90 0))
-
- (addraset r 91 (let res 1 (if (==f f g) [] (assign res 0)) res))
- (addraset r 92 (let res 1 (if (!=f f g) [] (assign res 0)) res))
- (addraset r 93 (let res 1 (if (<f f g) [] (assign res 0)) res))
- (addraset r 94 (let res 1 (if (>f f g) [] (assign res 0)) res))
- (addraset r 95 (let res 1 (if (<=f f g) [] (assign res 0)) res))
- (addraset r 96 (let res 1 (if (>=f f g) [] (assign res 0)) res))
-
- (addraset r 97 (==f (+f f 1.0) (+f g 1.0)))
- (addraset r 98 (!=f (+f f 1.0) (+f g 1.0)))
- (addraset r 99 (<f (+f f 1.0) (+f g 1.0)))
- (addraset r 100 (>f (+f f 1.0) (+f g 1.0)))
- (addraset r 101 (<=f (+f f 1.0) (+f g 1.0)))
- (addraset r 102 (>=f (+f f 1.0) (+f g 1.0)))
-
- (addraset r 103 (==f f (+f g 1.0)))
- (addraset r 104 (!=f f (+f g 1.0)))
- (addraset r 105 (<f f (+f g 1.0)))
- (addraset r 106 (>f f (+f g 1.0)))
- (addraset r 107 (<=f f (+f g 1.0)))
- (addraset r 108 (>=f f (+f g 1.0)))
-
- (addraset r 109 (==f (+f f 1.0) g))
- (addraset r 110 (!=f (+f f 1.0) g))
- (addraset r 111 (<f (+f f 1.0) g))
- (addraset r 112 (>f (+f f 1.0) g))
- (addraset r 113 (<=f (+f f 1.0) g))
- (addraset r 114 (>=f (+f f 1.0) g))
-
- (floataset d 20 (+f (floatofint x) 1.0))
- (addraset r 115 (intoffloat (+f f 1.0)))
-
- (floataset d 21 (+f f (load float "G")))
- (floataset d 22 (+f (load float "G") f))
- (floataset d 23 (-f f (load float "G")))
- (floataset d 24 (-f (load float "G") f))
- (floataset d 25 ( *f f (load float "G")))
- (floataset d 26 ( *f (load float "G") f))
- (floataset d 27 (/f f (load float "G")))
- (floataset d 28 (/f (load float "G") f))
-
- (floataset d 29 (+f ( *f f 2.0) (load float "G")))
- (floataset d 30 (+f (load float "G") ( *f f 2.0)))
- (floataset d 31 (-f ( *f f 2.0) (load float "G")))
- (floataset d 32 (-f (load float "G") ( *f f 2.0)))
- (floataset d 33 ( *f ( +f f 2.0) (load float "G")))
- (floataset d 34 ( *f (load float "G") ( +f f 2.0)))
- (floataset d 35 (/f ( *f f 2.0) (load float "G")))
- (floataset d 36 (/f (load float "G") ( *f f 2.0)))
-
- (floataset d 37 (-f f))
- (floataset d 38 (absf f))
-
- (addraset r 116 (mulh x y))
-)))))))
+++ /dev/null
-/**************************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. */
-/* */
-/* All rights reserved. This file is distributed under the terms of */
-/* the GNU Lesser General Public License version 2.1, with the */
-/* special exception on linking described in the file LICENSE. */
-/* */
-/**************************************************************************/
-
- .text
-
- .global call_gen_code
- .type call_gen_code, %function
- .align 0
-call_gen_code:
- mov ip, sp
- stmfd sp!, {r4, r5, r6, r7, r8, r9, fp, ip, lr, pc}
- sub fp, ip, #4
- @ r0 is function to call
- @ r1, r2, r3 are arguments 1, 2, 3
- mov r4, r0
- mov r0, r1
- mov r1, r2
- mov r2, r3
- mov lr, pc
- mov pc, r4
- ldmea fp, {r4, r5, r6, r7, r8, r9, fp, sp, pc}
-
- .global caml_c_call
- .type caml_c_call, %function
- .align 0
-caml_c_call:
- @ function to call is in r10
- mov pc, r10
+++ /dev/null
-/**************************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */
-/* */
-/* Copyright 2013 Institut National de Recherche en Informatique et */
-/* en Automatique. */
-/* */
-/* All rights reserved. This file is distributed under the terms of */
-/* the GNU Lesser General Public License version 2.1, with the */
-/* special exception on linking described in the file LICENSE. */
-/* */
-/**************************************************************************/
-
- .globl call_gen_code
- .align 2
-call_gen_code:
- /* Set up stack frame and save callee-save registers */
- stp x29, x30, [sp, -160]!
- add x29, sp, #0
- stp x19, x20, [sp, 16]
- stp x21, x22, [sp, 32]
- stp x23, x24, [sp, 48]
- stp x25, x26, [sp, 64]
- stp x27, x28, [sp, 80]
- stp d8, d9, [sp, 96]
- stp d10, d11, [sp, 112]
- stp d12, d13, [sp, 128]
- stp d14, d15, [sp, 144]
- /* Shuffle arguments */
- mov x8, x0
- mov x0, x1
- mov x1, x2
- mov x2, x3
- mov x3, x4
- /* Call generated asm */
- blr x8
- /* Reload callee-save registers and return address */
- ldp x19, x20, [sp, 16]
- ldp x21, x22, [sp, 32]
- ldp x23, x24, [sp, 48]
- ldp x25, x26, [sp, 64]
- ldp x27, x28, [sp, 80]
- ldp d8, d9, [sp, 96]
- ldp d10, d11, [sp, 112]
- ldp d12, d13, [sp, 128]
- ldp d14, d15, [sp, 144]
- ldp x29, x30, [sp], 160
- ret
-
- .globl caml_c_call
- .align 2
-caml_c_call:
- br x15
+(* TEST
+ * native
+*)
+
(* Check the effectiveness of optimized compilation of tuple binding
Ref: http://caml.inria.fr/mantis/view.php?id=4800
r := !r * x + y
done;
let x2 = Gc.allocated_bytes () in
- print_int !r;
assert (!r = 82);
assert(x1 -. x0 = x2 -. x1) (* check no allocation between x1 and x2 *)
[@@inline never]
let () = f ()
+
+
+
+(* MPR#7680 *)
+
+let f () =
+ let (a,b) =
+ try (1,2)
+ with _ -> assert false
+ in
+ if a + b = 3 then raise Not_found
+
+let () = try f (); assert false with Not_found -> ()
+++ /dev/null
-(function "catch_fact" (b:int)
- (catch (exit fact b 1)
- with (fact c acc)
- (if (== c 0) acc
- (exit fact (- c 1) ( * c acc)))))
+++ /dev/null
-
-(function "catch_exit" (b:int)
- (+ 33
- (catch
- (try (exit lbl 12)
- with var 456)
- with (lbl x) (+ x 789))))
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(function "checkbound2" (x: int y: int)
- (checkbound x y))
-
-(function "checkbound1" (x: int)
- (checkbound x 2))
+++ /dev/null
-("format_odd": string "odd %d\n\000")
-("format_even": string "even %d\n\000")
-
-(function "force_spill" (a:int) 0)
-
-(function "is_even" (b:int)
- (catch (exit even b)
- with (odd v)
- (if (== v 0) 0
- (seq
- (extcall "printf_int" "format_odd" v unit)
- (let v2 (- v 1)
- (app "force_spill" 0 int)
- (exit even v2))))
- and (even v)
- (if (== v 0) 1
- (seq
- (extcall "printf_int" "format_even" v unit)
- (exit odd (- v 1))))))
+++ /dev/null
-(function "is_even" (b:int)
- (catch (exit even b)
- with (odd v)
- (if (== v 0) 0
- (exit even (- v 1)))
- and (even v)
- (if (== v 0) 1
- (exit odd (- v 1)))))
\ No newline at end of file
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(function "fib" (n: int)
- (if (< n 2)
- 1
- (+ (app "fib" (- n 1) int)
- (app "fib" (- n 2) int))))
+++ /dev/null
-;*********************************************************************
-;* *
-;* OCaml *
-;* *
-;* Xavier Leroy, projet Cristal, INRIA Rocquencourt *
-;* *
-;* Copyright 1996 Institut National de Recherche en Informatique et *
-;* en Automatique. All rights reserved. This file is distributed *
-;* under the terms of the Q Public License version 1.0. *
-;* *
-;*********************************************************************
-
-; Must be preprocessed by cpp
-
-#ifdef SYS_hpux
-#define G(x) x
-#define CODESPACE .code
-#define CODE_ALIGN 4
-#define EXPORT_CODE(x) .export x, entry, priv_lev=3
-#define STARTPROC .proc ! .callinfo frame=0, no_calls ! .entry
-#define ENDPROC .exit ! .procend
-#endif
-
-#ifdef SYS_nextstep
-#define G(x) _##x
-#define CODESPACE .text
-#define CODE_ALIGN 2
-#define EXPORT_CODE(x) .globl x
-#define STARTPROC
-#define ENDPROC
-#endif
-
-#ifdef SYS_hpux
- .space $PRIVATE$
- .subspa $DATA$,quad=1,align=8,access=31
- .subspa $BSS$,quad=1,align=8,access=31,zero,sort=82
- .space $TEXT$
- .subspa $LIT$,quad=0,align=8,access=44
- .subspa $CODE$,quad=0,align=8,access=44,code_only
- .import $global$, data
- .import $$dyncall, millicode
-#endif
-
- CODESPACE
- .align CODE_ALIGN
- EXPORT_CODE(G(call_gen_code))
-G(call_gen_code):
- STARTPROC
- stw %r2,-20(%r30)
- ldo 256(%r30), %r30
-; Save the callee-save registers
- ldo -32(%r30), %r1
- stws,ma %r3, -4(%r1)
- stws,ma %r4, -4(%r1)
- stws,ma %r5, -4(%r1)
- stws,ma %r6, -4(%r1)
- stws,ma %r7, -4(%r1)
- stws,ma %r8, -4(%r1)
- stws,ma %r9, -4(%r1)
- stws,ma %r10, -4(%r1)
- stws,ma %r11, -4(%r1)
- stws,ma %r12, -4(%r1)
- stws,ma %r13, -4(%r1)
- stws,ma %r14, -4(%r1)
- stws,ma %r15, -4(%r1)
- stws,ma %r16, -4(%r1)
- stws,ma %r17, -4(%r1)
- stws,ma %r18, -4(%r1)
- fstds,ma %fr12, -8(%r1)
- fstds,ma %fr13, -8(%r1)
- fstds,ma %fr14, -8(%r1)
- fstds,ma %fr15, -8(%r1)
- fstds,ma %fr16, -8(%r1)
- fstds,ma %fr17, -8(%r1)
- fstds,ma %fr18, -8(%r1)
- fstds,ma %fr19, -8(%r1)
- fstds,ma %fr20, -8(%r1)
- fstds,ma %fr21, -8(%r1)
- fstds,ma %fr22, -8(%r1)
- fstds,ma %fr23, -8(%r1)
- fstds,ma %fr24, -8(%r1)
- fstds,ma %fr25, -8(%r1)
- fstds,ma %fr26, -8(%r1)
- fstds,ma %fr27, -8(%r1)
- fstds,ma %fr28, -8(%r1)
- fstds,ma %fr29, -8(%r1)
- fstds,ma %fr30, -8(%r1)
- fstds,ma %fr31, -8(%r1)
-
-; Shuffle the arguments and call
- copy %r26, %r22
- copy %r25, %r26
- copy %r24, %r25
- copy %r23, %r24
- fcpy,dbl %fr5, %fr4
-#ifdef SYS_hpux
- bl $$dyncall, %r2
- nop
-#else
- ble 0(4, %r22)
- copy %r31, %r2
-#endif
-; Shuffle the results
- copy %r26, %r28
-; Restore the callee-save registers
- ldo -32(%r30), %r1
- ldws,ma -4(%r1), %r3
- ldws,ma -4(%r1), %r4
- ldws,ma -4(%r1), %r5
- ldws,ma -4(%r1), %r6
- ldws,ma -4(%r1), %r7
- ldws,ma -4(%r1), %r8
- ldws,ma -4(%r1), %r9
- ldws,ma -4(%r1), %r10
- ldws,ma -4(%r1), %r11
- ldws,ma -4(%r1), %r12
- ldws,ma -4(%r1), %r13
- ldws,ma -4(%r1), %r14
- ldws,ma -4(%r1), %r15
- ldws,ma -4(%r1), %r16
- ldws,ma -4(%r1), %r17
- ldws,ma -4(%r1), %r18
- fldds,ma -8(%r1), %fr12
- fldds,ma -8(%r1), %fr13
- fldds,ma -8(%r1), %fr14
- fldds,ma -8(%r1), %fr15
- fldds,ma -8(%r1), %fr16
- fldds,ma -8(%r1), %fr17
- fldds,ma -8(%r1), %fr18
- fldds,ma -8(%r1), %fr19
- fldds,ma -8(%r1), %fr20
- fldds,ma -8(%r1), %fr21
- fldds,ma -8(%r1), %fr22
- fldds,ma -8(%r1), %fr23
- fldds,ma -8(%r1), %fr24
- fldds,ma -8(%r1), %fr25
- fldds,ma -8(%r1), %fr26
- fldds,ma -8(%r1), %fr27
- fldds,ma -8(%r1), %fr28
- fldds,ma -8(%r1), %fr29
- fldds,ma -8(%r1), %fr30
- fldds,ma -8(%r1), %fr31
-
- ldo -256(%r30), %r30
- ldw -20(%r30), %r2
- bv 0(%r2)
- nop
- ENDPROC
-
- .align CODE_ALIGN
- EXPORT_CODE(caml_c_call)
-G(caml_c_call):
- STARTPROC
-#ifdef SYS_hpux
- bl $$dyncall, %r0
- nop
-#else
- bv 0(%r22)
- nop
-#endif
- ENDPROC
+++ /dev/null
-/**************************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. */
-/* */
-/* All rights reserved. This file is distributed under the terms of */
-/* the GNU Lesser General Public License version 2.1, with the */
-/* special exception on linking described in the file LICENSE. */
-/* */
-/**************************************************************************/
-
-/* Linux with ELF binaries does not prefix identifiers with _.
- Linux with a.out binaries, FreeBSD, and NextStep do. */
-
-#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \
- || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_gnu)
-#define G(x) x
-#define FUNCTION_ALIGN 16
-#else
-#define G(x) _##x
-#define FUNCTION_ALIGN 4
-#endif
-
- .globl G(call_gen_code)
- .align FUNCTION_ALIGN
-G(call_gen_code):
- pushl %ebp
- movl %esp,%ebp
- pushl %ebx
- pushl %esi
- pushl %edi
- movl 12(%ebp),%eax
- movl 16(%ebp),%ebx
- movl 20(%ebp),%ecx
- movl 24(%ebp),%edx
- call *8(%ebp)
- popl %edi
- popl %esi
- popl %ebx
- popl %ebp
- ret
-
- .globl G(caml_c_call)
- .align FUNCTION_ALIGN
-G(caml_c_call):
- ffree %st(0)
- ffree %st(1)
- ffree %st(2)
- ffree %st(3)
- jmp *%eax
-
- .comm G(caml_exception_pointer), 4
- .comm G(young_ptr), 4
- .comm G(young_start), 4
+++ /dev/null
-;*********************************************************************;
-; ;
-; OCaml ;
-; ;
-; Xavier Leroy, projet Cristal, INRIA Rocquencourt ;
-; ;
-; Copyright 1996 Institut National de Recherche en Informatique et ;
-; en Automatique. All rights reserved. This file is distributed ;
-; under the terms of the Q Public License version 1.0. ;
-; ;
-;*********************************************************************;
-
- .386
- .MODEL FLAT
-
- .CODE
- PUBLIC _call_gen_code
- ALIGN 4
-_call_gen_code:
- push ebp
- mov ebp, esp
- push ebx
- push esi
- push edi
- mov eax, [ebp+12]
- mov ebx, [ebp+16]
- mov ecx, [ebp+20]
- mov edx, [ebp+24]
- call DWORD PTR [ebp+8]
- pop edi
- pop esi
- pop ebx
- pop ebp
- ret
-
- PUBLIC _caml_c_call
- ALIGN 4
-_caml_c_call:
- ffree st(0)
- ffree st(1)
- ffree st(2)
- ffree st(3)
- jmp eax
-
- PUBLIC _caml_call_gc
- PUBLIC _caml_alloc
- PUBLIC _caml_alloc1
- PUBLIC _caml_alloc2
- PUBLIC _caml_alloc3
-_caml_call_gc:
-_caml_alloc:
-_caml_alloc1:
-_caml_alloc2:
-_caml_alloc3:
- int 3
-
- .DATA
- PUBLIC _caml_exception_pointer
-_caml_exception_pointer dword 0
- PUBLIC _young_ptr
-_young_ptr dword 0
- PUBLIC _young_limit
-_young_limit dword 0
-
- END
+++ /dev/null
-/**************************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. */
-/* */
-/* All rights reserved. This file is distributed under the terms of */
-/* the GNU Lesser General Public License version 2.1, with the */
-/* special exception on linking described in the file LICENSE. */
-/* */
-/**************************************************************************/
-
-#define ST8OFF(a,b,d) st8 [a] = b, d
-#define LD8OFF(a,b,d) ld8 a = [b], d
-#define STFDOFF(a,b,d) stfd [a] = b, d
-#define LDFDOFF(a,b,d) ldfd a = [b], d
-#define STFSPILLOFF(a,b,d) stf.spill [a] = b, d
-#define LDFFILLOFF(a,b,d) ldf.fill a = [b], d
-
- .text
- .align 16
-
- .global call_gen_code#
- .proc call_gen_code#
-
-call_gen_code:
- /* Allocate 64 "out" registers (for the OCaml code) and no locals */
- alloc r3 = ar.pfs, 0, 0, 64, 0
-
- /* Save PFS, return address and GP on stack */
- add sp = -368, sp ;;
- add r2 = 16, sp ;;
- ST8OFF(r2,r3,8) ;;
- mov r3 = b0 ;;
- ST8OFF(r2,r3,8) ;;
- ST8OFF(r2,gp,8) ;;
-
- /* Save predicates on stack */
- mov r3 = pr ;;
- st8 [r2] = r3
-
- /* Save callee-save floating-point registers on stack */
- add r2 = 48, sp
- add r3 = 64, sp ;;
- STFSPILLOFF(r2,f2,16) ;;
- STFSPILLOFF(r3,f3,16) ;;
- STFSPILLOFF(r2,f4,16) ;;
- STFSPILLOFF(r3,f5,16) ;;
- STFSPILLOFF(r2,f16,16) ;;
- STFSPILLOFF(r3,f17,16) ;;
- STFSPILLOFF(r2,f18,16) ;;
- STFSPILLOFF(r3,f19,16) ;;
- STFSPILLOFF(r2,f20,16) ;;
- STFSPILLOFF(r3,f21,16) ;;
- STFSPILLOFF(r2,f22,16) ;;
- STFSPILLOFF(r3,f23,16) ;;
- STFSPILLOFF(r2,f24,16) ;;
- STFSPILLOFF(r3,f25,16) ;;
- STFSPILLOFF(r2,f26,16) ;;
- STFSPILLOFF(r3,f27,16) ;;
- STFSPILLOFF(r2,f28,16) ;;
- STFSPILLOFF(r3,f29,16) ;;
- STFSPILLOFF(r2,f30,16) ;;
- STFSPILLOFF(r3,f31,16) ;;
-
- /* Recover entry point and gp from the function pointer in in0 */
- LD8OFF(r2,r32,8) ;;
- ld8 r3 = [r32] ;;
- mov b6 = r2
- mov gp = r3 ;;
-
- /* Shift arguments r33 ... r35 to r32 ... r34 */
- mov r32 = r33
- mov r33 = r34
- mov r34 = r35
-
- /* Do the call */
- br.call.sptk b0 = b6 ;;
-
- /* Restore the saved floating-point registers */
- add r2 = 48, sp
- add r3 = 64, sp ;;
- LDFFILLOFF(f2,r2,16) ;;
- LDFFILLOFF(f3,r3,16) ;;
- LDFFILLOFF(f4,r2,16) ;;
- LDFFILLOFF(f5,r3,16) ;;
- LDFFILLOFF(f16,r2,16) ;;
- LDFFILLOFF(f17,r3,16) ;;
- LDFFILLOFF(f18,r2,16) ;;
- LDFFILLOFF(f19,r3,16) ;;
- LDFFILLOFF(f20,r2,16) ;;
- LDFFILLOFF(f21,r3,16) ;;
- LDFFILLOFF(f22,r2,16) ;;
- LDFFILLOFF(f23,r3,16) ;;
- LDFFILLOFF(f24,r2,16) ;;
- LDFFILLOFF(f25,r3,16) ;;
- LDFFILLOFF(f26,r2,16) ;;
- LDFFILLOFF(f27,r3,16) ;;
- LDFFILLOFF(f28,r2,16) ;;
- LDFFILLOFF(f29,r3,16) ;;
- LDFFILLOFF(f30,r2,16) ;;
- LDFFILLOFF(f31,r3,16) ;;
-
- /* Restore gp, predicates and return */
- add r2 = 16, sp ;;
- LD8OFF(r3,r2,8) ;;
- mov ar.pfs = r3
- LD8OFF(r3,r2,8) ;;
- mov b0 = r3
- LD8OFF(gp,r2,8) ;;
- LD8OFF(r3,r2,8) ;;
- mov pr = r3, -1
-
- br.ret.sptk.many b0 ;;
-
- .endp call_gen_code#
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(function "square" (x: float)
- ( *f x x))
-
-(function "integr" (f: addr low: float high: float n: int)
- (let (h (/f (-f high low) (floatofint n))
- x low
- s 0.0
- i n)
- (while (> i 0)
- (assign s (+f s (app f x float)))
- (assign x (+f x h))
- (assign i (- i 1)))
- ( *f s h)))
-
-(function "test" (n: int)
- (app "integr" "square" 0.0 1.0 n float))
+(* TEST
+ modules = "is_in_static_data.c"
+ * native
+*)
+
(* Data that should be statically allocated by the compiler (all versions) *)
external is_in_static_data : 'a -> bool = "caml_is_in_static_data"
+(* TEST
+ modules = "is_in_static_data.c is_static_flambda_dep.ml"
+ * flambda
+ ** native
+*)
+
(* Data that should be statically allocated by the compiler (flambda only) *)
external is_in_static_data : 'a -> bool = "caml_is_in_static_data"
type t = int
let compare (a:int) b = compare a b
end
-module IntMap = (Map.Make [@inlined])(Int)
+module IntMap = Map.Make (Int)
let () =
let f () =
+++ /dev/null
-val token: Lexing.lexbuf -> Parsecmm.token
-
-type error =
- Illegal_character
- | Unterminated_comment
- | Unterminated_string
-
-exception Error of error
-
-val report_error: Lexing.lexbuf -> error -> unit
+++ /dev/null
-{
-open Parsecmm
-
-type error =
- Illegal_character
- | Unterminated_comment
- | Unterminated_string
-
-exception Error of error
-
-(* For nested comments *)
-
-let comment_depth = ref 0
-
-(* The table of keywords *)
-
-let keyword_table =
- Misc.create_hashtable 149 [
- "absf", ABSF;
- "addr", ADDR;
- "align", ALIGN;
- "alloc", ALLOC;
- "and", AND;
- "app", APPLY;
- "assign", ASSIGN;
- "byte", BYTE;
- "case", CASE;
- "catch", CATCH;
- "checkbound", CHECKBOUND;
- "data", DATA;
- "exit", EXIT;
- "extcall", EXTCALL;
- "float", FLOAT;
- "float32", FLOAT32;
- "float64", FLOAT64;
- "floatofint", FLOATOFINT;
- "function", FUNCTION;
- "global", GLOBAL;
- "half", HALF;
- "if", IF;
- "int", INT;
- "int32", INT32;
- "intoffloat", INTOFFLOAT;
- "string", KSTRING;
- "let", LET;
- "load", LOAD;
- "mod", MODI;
- "mulh", MULH;
- "or", OR;
- "proj", PROJ;
- "raise_withtrace", RAISE Cmm.Raise_withtrace;
- "raise_notrace", RAISE Cmm.Raise_notrace;
- "seq", SEQ;
- "signed", SIGNED;
- "skip", SKIP;
- "store", STORE;
- "switch", SWITCH;
- "try", TRY;
- "unit", UNIT;
- "unsigned", UNSIGNED;
- "val", VAL;
- "while", WHILE;
- "with", WITH;
- "xor", XOR;
- "addraref", ADDRAREF;
- "intaref", INTAREF;
- "floataref", FLOATAREF;
- "addraset", ADDRASET;
- "intaset", INTASET;
- "floataset", FLOATASET
-]
-
-(* To buffer string literals *)
-
-let initial_string_buffer = Bytes.create 256
-let string_buff = ref initial_string_buffer
-let string_index = ref 0
-
-let reset_string_buffer () =
- string_buff := initial_string_buffer;
- string_index := 0
-
-let store_string_char c =
- if !string_index >= Bytes.length (!string_buff) then begin
- let new_buff = Bytes.create (Bytes.length (!string_buff) * 2) in
- Bytes.blit (!string_buff) 0 new_buff 0 (Bytes.length (!string_buff));
- string_buff := new_buff
- end;
- Bytes.unsafe_set (!string_buff) (!string_index) c;
- incr string_index
-
-let get_stored_string () =
- let s = Bytes.sub_string (!string_buff) 0 (!string_index) in
- string_buff := initial_string_buffer;
- s
-
-(* To translate escape sequences *)
-
-let char_for_backslash = function
- 'n' -> '\010'
- | 'r' -> '\013'
- | 'b' -> '\008'
- | 't' -> '\009'
- | c -> c
-
-let char_for_decimal_code lexbuf i =
- Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
- 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) +
- (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48))
-
-(* Error report *)
-
-let report_error lexbuf msg =
- prerr_string "Lexical error around character ";
- prerr_int (Lexing.lexeme_start lexbuf);
- match msg with
- Illegal_character ->
- prerr_string ": illegal character"
- | Unterminated_comment ->
- prerr_string ": unterminated comment"
- | Unterminated_string ->
- prerr_string ": unterminated string"
-
-}
-
-let newline = ('\013'* '\010')
-
-rule token = parse
- newline
- { Lexing.new_line lexbuf; token lexbuf }
- | [' ' '\009' '\012'] +
- { token lexbuf }
- | "+a" { ADDA }
- | "+v" { ADDV }
- | "+f" { ADDF }
- | "+" { ADDI }
- | ">>s" { ASR }
- | ":" { COLON }
- | "/f" { DIVF }
- | "/" { DIVI }
- | eof { EOF }
- | "==a" { EQA }
- | "==f" { EQF }
- | "==" { EQI }
- | ">=a" { GEA }
- | ">=f" { GEF }
- | ">=" { GEI }
- | ">a" { GTA }
- | ">f" { GTF }
- | ">" { GTI }
- | "[" { LBRACKET }
- | "<=a" { LEA }
- | "<=f" { LEF }
- | "<=" { LEI }
- | "(" { LPAREN }
- | "<<" { LSL }
- | ">>u" { LSR }
- | "<a" { LTA }
- | "<f" { LTF }
- | "<" { LTI }
- | "*f" { MULF }
- | "*" { STAR }
- | "!=a" { NEA }
- | "!=f" { NEF }
- | "!=" { NEI }
- | "]" { RBRACKET }
- | ")" { RPAREN }
- | "-f" { SUBF }
- | "-" { SUBI }
- | '-'? (['0'-'9']+ | "0x" ['0'-'9' 'a'-'f' 'A'-'F']+
- | "0o" ['0'-'7']+ | "0b" ['0'-'1']+)
- { INTCONST(int_of_string(Lexing.lexeme lexbuf)) }
- | '-'? ['0'-'9']+ 'a'
- { let s = Lexing.lexeme lexbuf in
- POINTER(int_of_string(String.sub s 0 (String.length s - 1))) }
- | '-'? ['0'-'9']+ ('.' ['0'-'9']*)? (['e' 'E'] ['+' '-']? ['0'-'9']+)?
- { FLOATCONST(Lexing.lexeme lexbuf) }
- | ['A'-'Z' 'a'-'z' '\223'-'\246' '\248'-'\255' ]
- (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255'
- '\'' '0'-'9' ]) * '/'? (['0'-'9'] *)
- { let s = Lexing.lexeme lexbuf in
- try
- Hashtbl.find keyword_table s
- with Not_found ->
- IDENT s }
- | "\""
- { reset_string_buffer();
- string lexbuf;
- STRING (get_stored_string()) }
- | "(*"
- { comment_depth := 1;
- comment lexbuf;
- token lexbuf }
- | '{' ['A' - 'Z' 'a'-'z' '/' ',' '.' '-' '_' ' ''0'-'9']+
- ':' [ '0'-'9' ]+ ',' ['0'-'9' ]+ '-' ['0'-'9' ]+ '}'
- {
- let loc_s = Lexing.lexeme lexbuf in
- let pos_fname, pos_lnum, start, end_ =
- Scanf.sscanf loc_s "{%s@:%i,%i-%i}" (fun file line start end_ ->
- (file, line, start, end_))
- in
- let loc_start =
- Lexing.{ pos_fname; pos_lnum; pos_bol = 0; pos_cnum = start }
- in
- let loc_end =
- Lexing.{ pos_fname; pos_lnum; pos_bol = 0; pos_cnum = end_ }
- in
- let location = Location.{ loc_start; loc_end; loc_ghost = false } in
- LOCATION location }
- | _ { raise(Error(Illegal_character)) }
-
-and comment = parse
- "(*"
- { comment_depth := succ !comment_depth; comment lexbuf }
- | "*)"
- { comment_depth := pred !comment_depth;
- if !comment_depth > 0 then comment lexbuf }
- | eof
- { raise (Error(Unterminated_comment)) }
- | newline
- { Lexing.new_line lexbuf; comment lexbuf }
- | _
- { comment lexbuf }
-
-and string = parse
- '"'
- { () }
- | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] +
- { string lexbuf }
- | '\\' ['\\' '"' 'n' 't' 'b' 'r']
- { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
- string lexbuf }
- | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
- { store_string_char(char_for_decimal_code lexbuf 1);
- string lexbuf }
- | eof
- { raise (Error(Unterminated_string)) }
- | _
- { store_string_char(Lexing.lexeme_char lexbuf 0);
- string lexbuf }
-
+++ /dev/null
-|***********************************************************************
-|* *
-|* OCaml *
-|* *
-|* Xavier Leroy, projet Cristal, INRIA Rocquencourt *
-|* *
-|* Copyright 1996 Institut National de Recherche en Informatique et *
-|* en Automatique. All rights reserved. This file is distributed *
-|* under the terms of the Q Public License version 1.0. *
-|* *
-|***********************************************************************
-
-| call_gen_code is used with the following types:
-| unit -> int
-| int -> int
-| int -> double
-| int * int * address -> void
-| int * int -> void
-| unit -> unit
-| Hence arg1 -> d0, arg2 -> d1, arg3 -> a0,
-| and we need a special case for int -> double
-
- .text
- .globl _call_gen_code
-_call_gen_code:
- link a6, #0
- movem d2-d7/a2-a6, a7@-
- fmovem fp2-fp7, a7@-
- movel a6@(8), a1
- movel a6@(12), d0
- movel a6@(16), d1
- movel a6@(20), a0
- jsr a1@
- fmovem a7@+, fp2-fp7
- movem a7@+, d2-d7/a2-a6
- unlk a6
- rts
-
- .globl _call_gen_code_float
-_call_gen_code_float:
- link a6, #0
- moveml d2-d7/a2-a6, a7@-
- fmovem fp2-fp7, a7@-
- movel a6@(8), a1
- movel a6@(12), d0
- jsr a1@
- fmoved fp0, a7@-
- movel a7@+, d0
- movel a7@+, d1
- fmovem a7@+, fp2-fp7
- moveml a7@+, d2-d7/a2-a6
- unlk a6
- rts
-
- .globl _caml_c_call
-_caml_c_call:
- jmp a0@
+++ /dev/null
-/**************************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. */
-/* */
-/* All rights reserved. This file is distributed under the terms of */
-/* the GNU Lesser General Public License version 2.1, with the */
-/* special exception on linking described in the file LICENSE. */
-/* */
-/**************************************************************************/
-
-#include <stddef.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <time.h>
-
-void caml_ml_array_bound_error(void)
-{
- fprintf(stderr, "Fatal error: out-of-bound access in array or string\n");
- exit(2);
-}
-
-void print_string(char * s)
-{
- fputs(s, stdout);
-}
-
-void printf_int(char * fmt, int arg)
-{
- printf(fmt, arg);
-}
-
-#ifdef SORT
-
-int cmpint(const void * i, const void * j)
-{
- long vi = *((long *) i);
- long vj = *((long *) j);
- if (vi == vj) return 0;
- if (vi < vj) return -1;
- return 1;
-}
-
-#endif
-
-int main(int argc, char **argv)
-{
-#ifdef UNIT_INT
- { extern long FUN(void);
- extern long call_gen_code(long (*)(void));
- printf("%ld\n", call_gen_code(FUN));
- }
-#else
- if (argc < 2) {
- fprintf(stderr, "Usage: %s [int arg]\n", argv[0]);
- exit(2);
- }
-#ifdef INT_INT
- { extern long FUN(long);
- extern long call_gen_code(long (*)(long), long);
- printf("%ld\n", call_gen_code(FUN, atoi(argv[1])));
- }
-#endif
-#ifdef INT_FLOAT
- { extern double FUN(long);
- extern double call_gen_code(double (*)(long), long);
- printf("%f\n", call_gen_code(FUN, atoi(argv[1])));
- }
-#endif
-#ifdef SORT
- { extern void FUN(long, long, long *);
- extern void call_gen_code(void (*)(long, long, long *), long, long, long *);
- long n;
- long * a, * b;
- long i;
-
- srand(argc >= 3 ? atoi(argv[2]) : time((time_t *) 0));
- n = atoi(argv[1]);
- a = (long *) malloc(n * sizeof(long));
- for (i = 0 ; i < n; i++) a[i] = rand() & 0xFFF;
-#ifdef DEBUG
- for (i = 0; i < n; i++) printf("%ld ", a[i]); printf("\n");
-#endif
- b = (long *) malloc(n * sizeof(long));
- for (i = 0; i < n; i++) b[i] = a[i];
- call_gen_code(FUN, 0, n-1, a);
-#ifdef DEBUG
- for (i = 0; i < n; i++) printf("%ld ", a[i]); printf("\n");
-#endif
- qsort(b, n, sizeof(long), cmpint);
- for (i = 0; i < n; i++) {
- if (a[i] != b[i]) { printf("Bug!\n"); return 2; }
- }
- printf("OK\n");
- }
-#endif
-#endif
-#ifdef CHECKBOUND
- { extern void checkbound1(long), checkbound2(long, long);
- extern void call_gen_code(void *, ...);
- long x, y;
- x = atoi(argv[1]);
- if (argc >= 3) {
- y = atoi(argv[2]);
- if ((unsigned long) x < (unsigned long) y)
- printf("Should not trap\n");
- else
- printf("Should trap\n");
- call_gen_code(checkbound2, y, x);
- } else {
- if (2 < (unsigned long) x)
- printf("Should not trap\n");
- else
- printf("Should trap\n");
- call_gen_code(checkbound1, x);
- }
- printf("OK\n");
- }
-#endif
- return 0;
-}
+++ /dev/null
-open Clflags
-let write_asm_file = ref false
-
-let compile_file filename =
- if !write_asm_file then begin
- let out_name = Filename.chop_extension filename ^ ".s" in
- Emitaux.output_channel := open_out out_name
- end; (* otherwise, stdout *)
- Compilenv.reset "test";
- Emit.begin_assembly();
- let ic = open_in filename in
- let lb = Lexing.from_channel ic in
- lb.Lexing.lex_curr_p <- { lb.Lexing.lex_curr_p with pos_fname = filename };
- try
- while true do
- Asmgen.compile_phrase Format.std_formatter
- (Parsecmm.phrase Lexcmm.token lb)
- done
- with
- End_of_file ->
- close_in ic; Emit.end_assembly();
- if !write_asm_file then close_out !Emitaux.output_channel
- | Lexcmm.Error msg ->
- close_in ic; Lexcmm.report_error lb msg
- | Parsing.Parse_error ->
- close_in ic;
- let start_p = Lexing.lexeme_start_p lb in
- let end_p = Lexing.lexeme_end_p lb in
- Printf.eprintf "File \"%s\", line %i, characters %i-%i:\n\
- Syntax error.\n%!"
- filename
- start_p.Lexing.pos_lnum
- (start_p.Lexing.pos_cnum - start_p.Lexing.pos_bol)
- (end_p.Lexing.pos_cnum - start_p.Lexing.pos_bol)
- | Parsecmmaux.Error msg ->
- close_in ic; Parsecmmaux.report_error msg
- | x ->
- close_in ic; raise x
-
-let usage = "Usage: codegen <options> <files>\noptions are:"
-
-let main() =
- Arg.parse [
- "-S", Arg.Set write_asm_file,
- " Output file to filename.s (default is stdout)";
- "-g", Arg.Set Clflags.debug, "";
- "-dcmm", Arg.Set dump_cmm, "";
- "-dcse", Arg.Set dump_cse, "";
- "-dsel", Arg.Set dump_selection, "";
- "-dlive", Arg.Unit(fun () -> dump_live := true;
- Printmach.print_live := true), "";
- "-dspill", Arg.Set dump_spill, "";
- "-dsplit", Arg.Set dump_split, "";
- "-dinterf", Arg.Set dump_interf, "";
- "-dprefer", Arg.Set dump_prefer, "";
- "-dalloc", Arg.Set dump_regalloc, "";
- "-dreload", Arg.Set dump_reload, "";
- "-dscheduling", Arg.Set dump_scheduling, "";
- "-dlinear", Arg.Set dump_linear, "";
- "-dtimings", Arg.Unit (fun () -> profile_columns := [ `Time ]), "";
- ] compile_file usage
-
-let () =
- main ();
- Profile.print Format.std_formatter !Clflags.profile_columns;
- exit 0
+++ /dev/null
-/**************************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. */
-/* */
-/* All rights reserved. This file is distributed under the terms of */
-/* the GNU Lesser General Public License version 2.1, with the */
-/* special exception on linking described in the file LICENSE. */
-/* */
-/**************************************************************************/
-
-#include <stdio.h>
-#include <math.h>
-#include <time.h>
-#include <stdlib.h>
-#include <string.h>
-
-#include "../../../byterun/caml/config.h"
-#define FMT ARCH_INTNAT_PRINTF_FORMAT
-
-void caml_ml_array_bound_error(void)
-{
- fprintf(stderr, "Fatal error: out-of-bound access in array or string\n");
- exit(2);
-}
-
-intnat R[200];
-double D[40];
-intnat X, Y;
-double F, G;
-
-#define INTTEST(arg,res) \
- { intnat result = (res); \
- if (arg != result) \
- printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: " \
- "result %"FMT"d, expected %"FMT"d\n", \
- #arg, #res, X, Y, arg, result); \
- }
-#define INTFLOATTEST(arg,res) \
- { intnat result = (res); \
- if (arg != result) \
- printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: "\
- "result %"FMT"d, expected %"FMT"d\n", \
- #arg, #res, F, G, arg, result); \
- }
-#define FLOATTEST(arg,res) \
- { double result = (res); \
- if (arg < result || arg > result) \
- printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: "\
- "result %.15g, expected %.15g\n", \
- #arg, #res, F, G, arg, result); \
- }
-#define FLOATINTTEST(arg,res) \
- { double result = (res); \
- if (arg < result || arg > result) \
- printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: "\
- "result %.15g, expected %.15g\n", \
- #arg, #res, X, Y, arg, result); \
- }
-
-extern void call_gen_code(void (*)(void));
-extern void testarith(void);
-static intnat mulhs(intnat x, intnat y);
-
-void do_test(void)
-{
- call_gen_code(testarith);
-
- INTTEST(R[0], 0);
- INTTEST(R[1], 1);
- INTTEST(R[2], -1);
- INTTEST(R[3], 256);
- INTTEST(R[4], 65536);
- INTTEST(R[5], 16777216);
- INTTEST(R[6], -256);
- INTTEST(R[7], -65536);
- INTTEST(R[8], -16777216);
-
- INTTEST(R[9], (X + Y));
- INTTEST(R[10], (X + 1));
- INTTEST(R[11], (X + -1));
-
- INTTEST(R[12], ((intnat) ((char *)R + 8)));
- INTTEST(R[13], ((intnat) ((char *)R + Y)));
-
- INTTEST(R[14], (X - Y));
- INTTEST(R[15], (X - 1));
- INTTEST(R[16], (X - -1));
-
- INTTEST(R[17], ((intnat) ((uintnat)R - 8)));
- INTTEST(R[18], ((intnat) ((char *)R - Y)));
-
- INTTEST(R[19], (X * 2));
- INTTEST(R[20], (2 * X));
- INTTEST(R[21], (X * 16));
- INTTEST(R[22], (16 * X));
- INTTEST(R[23], (X * 12345));
- INTTEST(R[24], (12345 * X));
- INTTEST(R[25], (X * Y));
-
- INTTEST(R[26], (X / 2));
- INTTEST(R[27], (X / 16));
- INTTEST(R[28], (X / 7));
- INTTEST(R[29], (Y != 0 ? X / Y : 0));
-
- INTTEST(R[30], (X % 2));
- INTTEST(R[31], (X % 16));
- INTTEST(R[32], (Y != 0 ? X % Y : 0));
-
- INTTEST(R[33], (X & Y));
- INTTEST(R[34], (X & 3));
- INTTEST(R[35], (3 & X));
-
- INTTEST(R[36], (X | Y));
- INTTEST(R[37], (X | 3));
- INTTEST(R[38], (3 | X));
-
- INTTEST(R[39], (X ^ Y));
- INTTEST(R[40], (X ^ 3));
- INTTEST(R[41], (3 ^ X));
-
- INTTEST(R[42], (X << Y));
- INTTEST(R[43], (X << 1));
- INTTEST(R[44], (X << 8));
-
- INTTEST(R[45], ((uintnat) X >> Y));
- INTTEST(R[46], ((uintnat) X >> 1));
- INTTEST(R[47], ((uintnat) X >> 8));
-
- INTTEST(R[48], (X >> Y));
- INTTEST(R[49], (X >> 1));
- INTTEST(R[50], (X >> 8));
-
- INTTEST(R[51], (X == Y));
- INTTEST(R[52], (X != Y));
- INTTEST(R[53], (X < Y));
- INTTEST(R[54], (X > Y));
- INTTEST(R[55], (X <= Y));
- INTTEST(R[56], (X >= Y));
- INTTEST(R[57], (X == 1));
- INTTEST(R[58], (X != 1));
- INTTEST(R[59], (X < 1));
- INTTEST(R[60], (X > 1));
- INTTEST(R[61], (X <= 1));
- INTTEST(R[62], (X >= 1));
-
- INTTEST(R[63], ((char *)X == (char *)Y));
- INTTEST(R[64], ((char *)X != (char *)Y));
- INTTEST(R[65], ((char *)X < (char *)Y));
- INTTEST(R[66], ((char *)X > (char *)Y));
- INTTEST(R[67], ((char *)X <= (char *)Y));
- INTTEST(R[68], ((char *)X >= (char *)Y));
- INTTEST(R[69], ((char *)X == (char *)1));
- INTTEST(R[70], ((char *)X != (char *)1));
- INTTEST(R[71], ((char *)X < (char *)1));
- INTTEST(R[72], ((char *)X > (char *)1));
- INTTEST(R[73], ((char *)X <= (char *)1));
- INTTEST(R[74], ((char *)X >= (char *)1));
-
- INTTEST(R[75], (X + (Y << 1)));
- INTTEST(R[76], (X + (Y << 2)));
- INTTEST(R[77], (X + (Y << 3)));
- INTTEST(R[78], (X - (Y << 1)));
- INTTEST(R[79], (X - (Y << 2)));
- INTTEST(R[80], (X - (Y << 3)));
-
- FLOATTEST(D[0], 0.0);
- FLOATTEST(D[1], 1.0);
- FLOATTEST(D[2], -1.0);
- FLOATTEST(D[3], (F + G));
- FLOATTEST(D[4], (F - G));
- FLOATTEST(D[5], (F * G));
- FLOATTEST(D[6], F / G);
-
- FLOATTEST(D[7], (F + (G + 1.0)));
- FLOATTEST(D[8], (F - (G + 1.0)));
- FLOATTEST(D[9], (F * (G + 1.0)));
- FLOATTEST(D[10], F / (G + 1.0));
-
- FLOATTEST(D[11], ((F + 1.0) + G));
- FLOATTEST(D[12], ((F + 1.0) - G));
- FLOATTEST(D[13], ((F + 1.0) * G));
- FLOATTEST(D[14], (F + 1.0) / G);
-
- FLOATTEST(D[15], ((F + 1.0) + (G + 1.0)));
- FLOATTEST(D[16], ((F + 1.0) - (G + 1.0)));
- FLOATTEST(D[17], ((F + 1.0) * (G + 1.0)));
- FLOATTEST(D[18], (F + 1.0) / (G + 1.0));
-
- INTFLOATTEST(R[81], (F == G));
- INTFLOATTEST(R[82], (F != G));
- INTFLOATTEST(R[83], (F < G));
- INTFLOATTEST(R[84], (F > G));
- INTFLOATTEST(R[85], (F <= G));
- INTFLOATTEST(R[86], (F >= G));
-
- FLOATINTTEST(D[19], (double) X);
- INTFLOATTEST(R[87], (intnat) F);
-
- INTTEST(R[88], (X >= 0) && (X < Y));
- INTTEST(R[89], (0 < Y));
- INTTEST(R[90], (5 < Y));
-
- INTFLOATTEST(R[91], (F == G));
- INTFLOATTEST(R[92], (F != G));
- INTFLOATTEST(R[93], (F < G));
- INTFLOATTEST(R[94], (F > G));
- INTFLOATTEST(R[95], (F <= G));
- INTFLOATTEST(R[96], (F >= G));
-
- INTFLOATTEST(R[97], (F + 1.0 == G + 1.0));
- INTFLOATTEST(R[98], (F + 1.0 != G + 1.0));
- INTFLOATTEST(R[99], (F + 1.0 < G + 1.0));
- INTFLOATTEST(R[100], (F + 1.0 > G + 1.0));
- INTFLOATTEST(R[101], (F + 1.0 <= G + 1.0));
- INTFLOATTEST(R[102], (F + 1.0 >= G + 1.0));
-
- INTFLOATTEST(R[103], (F == G + 1.0));
- INTFLOATTEST(R[104], (F != G + 1.0));
- INTFLOATTEST(R[105], (F < G + 1.0));
- INTFLOATTEST(R[106], (F > G + 1.0));
- INTFLOATTEST(R[107], (F <= G + 1.0));
- INTFLOATTEST(R[108], (F >= G + 1.0));
-
- INTFLOATTEST(R[109], (F + 1.0 == G));
- INTFLOATTEST(R[110], (F + 1.0 != G));
- INTFLOATTEST(R[111], (F + 1.0 < G));
- INTFLOATTEST(R[112], (F + 1.0 > G));
- INTFLOATTEST(R[113], (F + 1.0 <= G));
- INTFLOATTEST(R[114], (F + 1.0 >= G));
-
- FLOATINTTEST(D[20], ((double) X) + 1.0);
- INTFLOATTEST(R[115], (intnat)(F + 1.0));
-
- FLOATTEST(D[21], F + G);
- FLOATTEST(D[22], G + F);
- FLOATTEST(D[23], F - G);
- FLOATTEST(D[24], G - F);
- FLOATTEST(D[25], F * G);
- FLOATTEST(D[26], G * F);
- FLOATTEST(D[27], F / G);
- FLOATTEST(D[28], G / F);
-
- FLOATTEST(D[29], (F * 2.0) + G);
- FLOATTEST(D[30], G + (F * 2.0));
- FLOATTEST(D[31], (F * 2.0) - G);
- FLOATTEST(D[32], G - (F * 2.0));
- FLOATTEST(D[33], (F + 2.0) * G);
- FLOATTEST(D[34], G * (F + 2.0));
- FLOATTEST(D[35], (F * 2.0) / G);
- FLOATTEST(D[36], G / (F * 2.0));
-
- FLOATTEST(D[37], - F);
- FLOATTEST(D[38], fabs(F));
-
- INTTEST(R[116], mulhs(X, Y));
-}
-
-/* Multiply-high signed. Hacker's Delight section 8.2 */
-
-#define HALFSIZE (4 * sizeof(intnat))
-#define HALFMASK (((intnat)1 << HALFSIZE) - 1)
-
-static intnat mulhs(intnat u, intnat v)
-{
- uintnat u0, v0, w0;
- intnat u1, v1, w1, w2, t;
- u0 = u & HALFMASK; u1 = u >> HALFSIZE;
- v0 = v & HALFMASK; v1 = v >> HALFSIZE;
- w0 = u0*v0;
- t = u1*v0 + (w0 >> HALFSIZE);
- w1 = t & HALFMASK;
- w2 = t >> HALFSIZE;
- w1 = u0*v1 + w1;
- return u1*v1 + w2 + (w1 >> HALFSIZE);
-}
-
-/* A simple linear congruential PRNG */
-
-#ifdef ARCH_SIXTYFOUR
-#define RAND_A 6364136223846793005ULL
-#define RAND_C 1442695040888963407ULL
-#else
-#define RAND_A 214013U
-#define RAND_C 2531011U
-#endif
-
-static intnat rnd(void)
-{
- static uintnat seed = 0;
- seed = seed * RAND_A + RAND_C;
- return (intnat) seed;
-}
-
-/* Test harness */
-
-#define NUM_RANDOM_ITERATIONS 1000000
-
-int main(int argc, char **argv)
-{
- int i;
- double weird[4];
-
- if (argc >= 5) {
- X = atoi(argv[1]);
- Y = atoi(argv[2]);
- sscanf(argv[3], "%lf", &F);
- sscanf(argv[4], "%lf", &G);
- do_test();
- return 0;
- }
- printf("Testing -2...2\n");
- for(Y = -2; Y <= 2; Y++) {
- for (X = -2; X <= 2; X++) {
- F = X; G = Y; do_test();
- }
- }
- if (!(argc >= 2 && strcmp(argv[1], "noinf"))) {
- printf("Testing special FP values\n");
- weird[0] = 0.0;
- weird[1] = 1.0 / weird[0]; /* +infty */
- weird[2] = -1.0 / weird[0]; /* -infty */
- weird[3] = 0.0 / weird[0]; /* NaN */
- for (X = 0; X < 4; X++) {
- for (Y = 0; Y < 4; Y++) {
- F = weird[X]; G = weird[Y]; do_test();
- }
- }
- }
- printf("Testing %d random values\n", NUM_RANDOM_ITERATIONS);
- for (i = 0; i < NUM_RANDOM_ITERATIONS; i++) {
- X = rnd();
- Y = rnd();
- F = X / 1e3;
- G = Y / 1e3;
- do_test();
- }
- return 0;
-}
+++ /dev/null
-/**************************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. */
-/* */
-/* All rights reserved. This file is distributed under the terms of */
-/* the GNU Lesser General Public License version 2.1, with the */
-/* special exception on linking described in the file LICENSE. */
-/* */
-/**************************************************************************/
-
- .globl call_gen_code
- .ent call_gen_code
-call_gen_code:
- subu $sp, $sp, 0x90
- sd $31, 0x88($sp)
- /* Save all callee-save registers */
- sd $16, 0x0($sp)
- sd $17, 0x8($sp)
- sd $18, 0x10($sp)
- sd $19, 0x18($sp)
- sd $20, 0x20($sp)
- sd $21, 0x28($sp)
- sd $22, 0x30($sp)
- sd $23, 0x38($sp)
- sd $30, 0x40($sp)
- s.d $f20, 0x48($sp)
- s.d $f22, 0x50($sp)
- s.d $f24, 0x58($sp)
- s.d $f26, 0x60($sp)
- s.d $f28, 0x68($sp)
- s.d $f30, 0x70($sp)
- /* Shuffle arguments */
- move $8, $5
- move $9, $6
- move $10, $7
- move $25, $4
- jal $4
- /* Restore registers */
- ld $31, 0x88($sp)
- ld $16, 0x0($sp)
- ld $17, 0x8($sp)
- ld $18, 0x10($sp)
- ld $19, 0x18($sp)
- ld $20, 0x20($sp)
- ld $21, 0x28($sp)
- ld $22, 0x30($sp)
- ld $23, 0x38($sp)
- ld $30, 0x40($sp)
- l.d $f20, 0x48($sp)
- l.d $f22, 0x50($sp)
- l.d $f24, 0x58($sp)
- l.d $f26, 0x60($sp)
- l.d $f28, 0x68($sp)
- l.d $f30, 0x70($sp)
- addu $sp, $sp, 0x90
- j $31
-
- .end call_gen_code
-
-/* Call a C function */
-
- .globl caml_c_call
- .ent caml_c_call
-caml_c_call:
- move $25, $24
- j $24
- .end caml_c_call
--- /dev/null
+bind_tuples.ml
+is_static_flambda.ml
+is_static.ml
+optargs.ml
+register_typing.ml
+register_typing_switch.ml
+staticalloc.ml
+static_float_array_flambda.ml
+static_float_array_flambda_opaque.ml
+unrolling_flambda2.ml
+unrolling_flambda.ml
+(* TEST
+ flags = "-g"
+ compare_programs = "false"
+ * native
+*)
+
(* Check the effectiveness of inlining the wrapper which fills in
default values for optional arguments.
+++ /dev/null
-/* A simple parser for C-- */
-
-%{
-open Cmm
-open Parsecmmaux
-
-let rec make_letdef def body =
- match def with
- [] -> body
- | (id, def) :: rem ->
- unbind_ident id;
- Clet(id, def, make_letdef rem body)
-
-let make_switch n selector caselist =
- let index = Array.make n 0 in
- let casev = Array.of_list caselist in
- let actv = Array.make (Array.length casev) (Cexit(0,[])) in
- for i = 0 to Array.length casev - 1 do
- let (posl, e) = casev.(i) in
- List.iter (fun pos -> index.(pos) <- i) posl;
- actv.(i) <- e
- done;
- Cswitch(selector, index, actv, Debuginfo.none)
-
-let access_array base numelt size =
- match numelt with
- Cconst_int 0 -> base
- | Cconst_int n -> Cop(Cadda, [base; Cconst_int(n * size)], Debuginfo.none)
- | _ -> Cop(Cadda, [base;
- Cop(Clsl, [numelt; Cconst_int(Misc.log2 size)],
- Debuginfo.none)],
- Debuginfo.none)
-
-%}
-
-%token ABSF
-%token ADDA
-%token ADDF
-%token ADDI
-%token ADDV
-%token ADDR
-%token ALIGN
-%token ALLOC
-%token AND
-%token APPLY
-%token ASR
-%token ASSIGN
-%token BYTE
-%token CASE
-%token CATCH
-%token CHECKBOUND
-%token COLON
-%token DATA
-%token DIVF
-%token DIVI
-%token EOF
-%token EQA
-%token EQF
-%token EQI
-%token EXIT
-%token EXTCALL
-%token FLOAT
-%token FLOAT32
-%token FLOAT64
-%token <string> FLOATCONST
-%token FLOATOFINT
-%token FUNCTION
-%token GEA
-%token GEF
-%token GEI
-%token GLOBAL
-%token GTA
-%token GTF
-%token GTI
-%token HALF
-%token <string> IDENT
-%token IF
-%token INT
-%token INT32
-%token <int> INTCONST
-%token INTOFFLOAT
-%token KSTRING
-%token LBRACKET
-%token LEA
-%token LEF
-%token LEI
-%token LET
-%token LOAD
-%token <Location.t> LOCATION
-%token LPAREN
-%token LSL
-%token LSR
-%token LTA
-%token LTF
-%token LTI
-%token MODI
-%token MULF
-%token MULH
-%token MULI
-%token NEA
-%token NEF
-%token NEI
-%token OR
-%token <int> POINTER
-%token PROJ
-%token <Cmm.raise_kind> RAISE
-%token RBRACKET
-%token RPAREN
-%token SEQ
-%token SIGNED
-%token SKIP
-%token STAR
-%token STORE
-%token <string> STRING
-%token SUBF
-%token SUBI
-%token SWITCH
-%token TRY
-%token UNIT
-%token UNSIGNED
-%token VAL
-%token WHILE
-%token WITH
-%token XOR
-%token ADDRAREF
-%token INTAREF
-%token FLOATAREF
-%token ADDRASET
-%token INTASET
-%token FLOATASET
-
-%start phrase
-%type <Cmm.phrase> phrase
-
-%%
-
-phrase:
- fundecl { Cfunction $1 }
- | datadecl { Cdata $1 }
- | EOF { raise End_of_file }
-;
-fundecl:
- LPAREN FUNCTION fun_name LPAREN params RPAREN sequence RPAREN
- { List.iter (fun (id, ty) -> unbind_ident id) $5;
- {fun_name = $3; fun_args = $5; fun_body = $7; fun_fast = true;
- fun_dbg = debuginfo ()} }
-;
-fun_name:
- STRING { $1 }
- | IDENT { $1 }
-params:
- oneparam params { $1 :: $2 }
- | /**/ { [] }
-;
-oneparam:
- IDENT COLON machtype { (bind_ident $1, $3) }
-;
-machtype:
- UNIT { [||] }
- | componentlist { Array.of_list(List.rev $1) }
-;
-component:
- VAL { Val }
- | ADDR { Addr }
- | INT { Int }
- | FLOAT { Float }
-;
-componentlist:
- component { [$1] }
- | componentlist STAR component { $3 :: $1 }
-;
-expr:
- INTCONST { Cconst_int $1 }
- | FLOATCONST { Cconst_float (float_of_string $1) }
- | STRING { Cconst_symbol $1 }
- | POINTER { Cconst_pointer $1 }
- | IDENT { Cvar(find_ident $1) }
- | LBRACKET RBRACKET { Ctuple [] }
- | LPAREN LET letdef sequence RPAREN { make_letdef $3 $4 }
- | LPAREN ASSIGN IDENT expr RPAREN { Cassign(find_ident $3, $4) }
- | LPAREN APPLY location expr exprlist machtype RPAREN
- { Cop(Capply $6, $4 :: List.rev $5, debuginfo ?loc:$3 ()) }
- | LPAREN EXTCALL STRING exprlist machtype RPAREN
- {Cop(Cextcall($3, $5, false, None), List.rev $4, debuginfo ())}
- | LPAREN ALLOC exprlist RPAREN { Cop(Calloc, List.rev $3, debuginfo ()) }
- | LPAREN SUBF expr RPAREN { Cop(Cnegf, [$3], debuginfo ()) }
- | LPAREN SUBF expr expr RPAREN { Cop(Csubf, [$3; $4], debuginfo ()) }
- | LPAREN unaryop expr RPAREN { Cop($2, [$3], debuginfo ()) }
- | LPAREN binaryop expr expr RPAREN { Cop($2, [$3; $4], debuginfo ()) }
- | LPAREN SEQ sequence RPAREN { $3 }
- | LPAREN IF expr expr expr RPAREN { Cifthenelse($3, $4, $5) }
- | LPAREN SWITCH INTCONST expr caselist RPAREN { make_switch $3 $4 $5 }
- | LPAREN WHILE expr sequence RPAREN
- { let body =
- match $3 with
- Cconst_int x when x <> 0 -> $4
- | _ -> Cifthenelse($3, $4, (Cexit(0,[]))) in
- Ccatch(Recursive, [0, [], Cloop body], Ctuple []) }
- | LPAREN EXIT IDENT exprlist RPAREN
- { Cexit(find_label $3, List.rev $4) }
- | LPAREN CATCH sequence WITH catch_handlers RPAREN
- { let handlers = $5 in
- List.iter (fun (_, l, _) -> List.iter unbind_ident l) handlers;
- Ccatch(Recursive, handlers, $3) }
- | EXIT { Cexit(0,[]) }
- | LPAREN TRY sequence WITH bind_ident sequence RPAREN
- { unbind_ident $5; Ctrywith($3, $5, $6) }
- | LPAREN VAL expr expr RPAREN
- { Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr],
- debuginfo ()) }
- | LPAREN ADDRAREF expr expr RPAREN
- { Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr],
- Debuginfo.none) }
- | LPAREN INTAREF expr expr RPAREN
- { Cop(Cload (Word_int, Mutable), [access_array $3 $4 Arch.size_int],
- Debuginfo.none) }
- | LPAREN FLOATAREF expr expr RPAREN
- { Cop(Cload (Double_u, Mutable), [access_array $3 $4 Arch.size_float],
- Debuginfo.none) }
- | LPAREN ADDRASET expr expr expr RPAREN
- { Cop(Cstore (Word_val, Assignment),
- [access_array $3 $4 Arch.size_addr; $5], Debuginfo.none) }
- | LPAREN INTASET expr expr expr RPAREN
- { Cop(Cstore (Word_int, Assignment),
- [access_array $3 $4 Arch.size_int; $5], Debuginfo.none) }
- | LPAREN FLOATASET expr expr expr RPAREN
- { Cop(Cstore (Double_u, Assignment),
- [access_array $3 $4 Arch.size_float; $5], Debuginfo.none) }
-;
-exprlist:
- exprlist expr { $2 :: $1 }
- | /**/ { [] }
-;
-letdef:
- oneletdef { [$1] }
- | LPAREN letdefmult RPAREN { $2 }
-;
-letdefmult:
- /**/ { [] }
- | oneletdef letdefmult { $1 :: $2 }
-;
-oneletdef:
- IDENT expr { (bind_ident $1, $2) }
-;
-chunk:
- UNSIGNED BYTE { Byte_unsigned }
- | SIGNED BYTE { Byte_signed }
- | UNSIGNED HALF { Sixteen_unsigned }
- | SIGNED HALF { Sixteen_signed }
- | UNSIGNED INT32 { Thirtytwo_unsigned }
- | SIGNED INT32 { Thirtytwo_signed }
- | INT { Word_int }
- | ADDR { Word_val }
- | FLOAT32 { Single }
- | FLOAT64 { Double }
- | FLOAT { Double_u }
- | VAL { Word_val }
-;
-unaryop:
- LOAD chunk { Cload ($2, Mutable) }
- | FLOATOFINT { Cfloatofint }
- | INTOFFLOAT { Cintoffloat }
- | RAISE { Craise $1 }
- | ABSF { Cabsf }
-;
-binaryop:
- STORE chunk { Cstore ($2, Assignment) }
- | ADDI { Caddi }
- | SUBI { Csubi }
- | STAR { Cmuli }
- | DIVI { Cdivi }
- | MODI { Cmodi }
- | AND { Cand }
- | OR { Cor }
- | XOR { Cxor }
- | LSL { Clsl }
- | LSR { Clsr }
- | ASR { Casr }
- | EQI { Ccmpi Ceq }
- | NEI { Ccmpi Cne }
- | LTI { Ccmpi Clt }
- | LEI { Ccmpi Cle }
- | GTI { Ccmpi Cgt }
- | GEI { Ccmpi Cge }
- | ADDA { Cadda }
- | ADDV { Caddv }
- | EQA { Ccmpa Ceq }
- | NEA { Ccmpa Cne }
- | LTA { Ccmpa Clt }
- | LEA { Ccmpa Cle }
- | GTA { Ccmpa Cgt }
- | GEA { Ccmpa Cge }
- | ADDF { Caddf }
- | MULF { Cmulf }
- | DIVF { Cdivf }
- | EQF { Ccmpf Ceq }
- | NEF { Ccmpf Cne }
- | LTF { Ccmpf Clt }
- | LEF { Ccmpf Cle }
- | GTF { Ccmpf Cgt }
- | GEF { Ccmpf Cge }
- | CHECKBOUND { Ccheckbound }
- | MULH { Cmulhi }
-;
-sequence:
- expr sequence { Csequence($1, $2) }
- | expr { $1 }
-;
-caselist:
- onecase sequence caselist { ($1, $2) :: $3 }
- | /**/ { [] }
-;
-onecase:
- CASE INTCONST COLON onecase { $2 :: $4 }
- | CASE INTCONST COLON { [$2] }
-;
-bind_ident:
- IDENT { bind_ident $1 }
-;
-datadecl:
- LPAREN datalist RPAREN { List.rev $2 }
- | LPAREN DATA datalist RPAREN { List.rev $3 }
-;
-datalist:
- datalist dataitem { $2 :: $1 }
- | /**/ { [] }
-;
-dataitem:
- STRING COLON { Cdefine_symbol $1 }
- | BYTE INTCONST { Cint8 $2 }
- | HALF INTCONST { Cint16 $2 }
- | INT INTCONST { Cint(Nativeint.of_int $2) }
- | FLOAT FLOATCONST { Cdouble (float_of_string $2) }
- | ADDR STRING { Csymbol_address $2 }
- | VAL STRING { Csymbol_address $2 }
- | KSTRING STRING { Cstring $2 }
- | SKIP INTCONST { Cskip $2 }
- | ALIGN INTCONST { Calign $2 }
- | GLOBAL STRING { Cglobal_symbol $2 }
-;
-catch_handlers:
- | catch_handler
- { [$1] }
- | catch_handler AND catch_handlers
- { $1 :: $3 }
-
-catch_handler:
- | sequence
- { 0, [], $1 }
- | LPAREN IDENT bind_identlist RPAREN sequence
- { find_label $2, $3, $5 }
-
-bind_identlist:
- /**/ { [] }
- | bind_ident bind_identlist { $1 :: $2 }
-
-location:
- /**/ { None }
- | LOCATION { Some $1 }
+++ /dev/null
-(* Auxiliary functions for parsing *)
-
-type error =
- Unbound of string
-
-exception Error of error
-
-let tbl_ident = (Hashtbl.create 57 : (string, Ident.t) Hashtbl.t)
-let tbl_label = (Hashtbl.create 57 : (string, int) Hashtbl.t)
-
-let ident_name s =
- match String.index s '/' with
- | exception Not_found -> s
- | n -> String.sub s 0 n
-
-let bind_ident s =
- let id = Ident.create (ident_name s) in
- Hashtbl.add tbl_ident s id;
- id
-
-let find_ident s =
- try
- Hashtbl.find tbl_ident s
- with Not_found ->
- raise(Error(Unbound s))
-
-let unbind_ident id =
- Hashtbl.remove tbl_ident (Ident.name id)
-
-let find_label s =
- try
- Hashtbl.find tbl_label s
- with Not_found ->
- let lbl = Lambda.next_raise_count () in
- Hashtbl.add tbl_label s lbl;
- lbl
-
-let report_error = function
- Unbound s ->
- prerr_string "Unbound identifier "; prerr_string s; prerr_endline "."
-
-let debuginfo ?(loc=Location.symbol_rloc ()) () =
- Debuginfo.(from_location loc)
+++ /dev/null
-(* Auxiliary functions for parsing *)
-
-val bind_ident: string -> Ident.t
-val find_ident: string -> Ident.t
-val unbind_ident: Ident.t -> unit
-
-val find_label: string -> int
-
-val debuginfo: ?loc:Location.t -> unit -> Debuginfo.t
-
-type error =
- Unbound of string
-
-exception Error of error
-
-val report_error: error -> unit
+++ /dev/null
-(function "pgcd_30030" (a:int)
- (catch (exit pgcd a 30030)
- with (pgcd n m)
- (if (> n m)
- (exit pgcd m n)
- (if (== n 0)
- m
- (let (r (mod m n))
- (exit pgcd r n))))))
\ No newline at end of file
+++ /dev/null
-/*********************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/*********************************************************************/
-
-#if defined(MODEL_ppc64) || defined(MODEL_ppc64le)
-#define EITHER(a,b) b
-#else
-#define EITHER(a,b) a
-#endif
-
-#define WORD EITHER(4,8)
-#define lg EITHER(lwz,ld)
-#define lgu EITHER(lwzu,ldu)
-#define stg EITHER(stw,std)
-#define stgu EITHER(stwu,stdu)
-
-#if defined(MODEL_ppc)
-#define RESERVED_STACK 16
-#define LR_SAVE_AREA 4
-#endif
-#if defined(MODEL_ppc64)
-#define RESERVED_STACK 48
-#define LR_SAVE_AREA 16
-#endif
-#if defined(MODEL_ppc64le)
-#define RESERVED_STACK 32
-#define LR_SAVE_AREA 16
-#endif
-
-/* Function definitions */
-
-#if defined(MODEL_ppc)
-#define FUNCTION(name) \
- .section ".text"; \
- .globl name; \
- .type name, @function; \
- .align 2; \
- name:
-#endif
-
-#if defined(MODEL_ppc64)
-#define FUNCTION(name) \
- .section ".opd","aw"; \
- .align 3; \
- .globl name; \
- .type name, @function; \
- name: .quad .L.name,.TOC.@tocbase; \
- .text; \
- .align 2; \
- .L.name:
-#endif
-
-#if defined(MODEL_ppc64le)
-#define FUNCTION(name) \
- .section ".text"; \
- .globl name; \
- .type name, @function; \
- .align 2; \
- name: ; \
- 0: addis 2, 12, (.TOC. - 0b)@ha; \
- addi 2, 2, (.TOC. - 0b)@l; \
- .localentry name, . - 0b
-#endif
-
-FUNCTION(call_gen_code)
- /* Allocate and link stack frame */
- stgu 1, -(WORD*18 + 8*18 + RESERVED_STACK)(1)
- /* 18 saved GPRs, 18 saved FPRs */
- /* Save return address */
- mflr 0
- stg 0, (WORD*18 + 8*18 + RESERVED_STACK + LR_SAVE_AREA)(1)
- /* Save all callee-save registers, starting at RESERVED_STACK */
- addi 11, 1, RESERVED_STACK - WORD
- stgu 14, WORD(11)
- stgu 15, WORD(11)
- stgu 16, WORD(11)
- stgu 17, WORD(11)
- stgu 18, WORD(11)
- stgu 19, WORD(11)
- stgu 20, WORD(11)
- stgu 21, WORD(11)
- stgu 22, WORD(11)
- stgu 23, WORD(11)
- stgu 24, WORD(11)
- stgu 25, WORD(11)
- stgu 26, WORD(11)
- stgu 27, WORD(11)
- stgu 28, WORD(11)
- stgu 29, WORD(11)
- stgu 30, WORD(11)
- stgu 31, WORD(11)
- stfdu 14, 8(11)
- stfdu 15, 8(11)
- stfdu 16, 8(11)
- stfdu 17, 8(11)
- stfdu 18, 8(11)
- stfdu 19, 8(11)
- stfdu 20, 8(11)
- stfdu 21, 8(11)
- stfdu 22, 8(11)
- stfdu 23, 8(11)
- stfdu 24, 8(11)
- stfdu 25, 8(11)
- stfdu 26, 8(11)
- stfdu 27, 8(11)
- stfdu 28, 8(11)
- stfdu 29, 8(11)
- stfdu 30, 8(11)
- stfdu 31, 8(11)
- /* Get function pointer in CTR */
-#if defined(MODEL_ppc)
- mtctr 3
-#elif defined(MODEL_ppc64)
- ld 0, 0(3)
- mtctr 0
- ld 2, 8(3)
-#elif defined(MODEL_ppc64le)
- mtctr 3
- mr 12, 3
-#else
-#error "wrong MODEL"
-#endif
- /* Shuffle arguments */
- mr 3, 4
- mr 4, 5
- mr 5, 6
- mr 6, 7
- /* Call the function */
- bctrl
- /* Restore callee-save registers */
- addi 11, 1, RESERVED_STACK - WORD
- lgu 14, WORD(11)
- lgu 15, WORD(11)
- lgu 16, WORD(11)
- lgu 17, WORD(11)
- lgu 18, WORD(11)
- lgu 19, WORD(11)
- lgu 20, WORD(11)
- lgu 21, WORD(11)
- lgu 22, WORD(11)
- lgu 23, WORD(11)
- lgu 24, WORD(11)
- lgu 25, WORD(11)
- lgu 26, WORD(11)
- lgu 27, WORD(11)
- lgu 28, WORD(11)
- lgu 29, WORD(11)
- lgu 30, WORD(11)
- lgu 31, WORD(11)
- lfdu 14, 8(11)
- lfdu 15, 8(11)
- lfdu 16, 8(11)
- lfdu 17, 8(11)
- lfdu 18, 8(11)
- lfdu 19, 8(11)
- lfdu 20, 8(11)
- lfdu 21, 8(11)
- lfdu 22, 8(11)
- lfdu 23, 8(11)
- lfdu 24, 8(11)
- lfdu 25, 8(11)
- lfdu 26, 8(11)
- lfdu 27, 8(11)
- lfdu 28, 8(11)
- lfdu 29, 8(11)
- lfdu 30, 8(11)
- lfdu 31, 8(11)
- /* Reload return address */
- lg 0, (WORD*18 + 8*18 + RESERVED_STACK + LR_SAVE_AREA)(1)
- mtlr 0
- /* Return */
- addi 1, 1, (WORD*18 + 8*18 + RESERVED_STACK)
- blr
-
-FUNCTION(caml_c_call)
- /* Jump to C function (address in r28) */
-#if defined(MODEL_ppc)
- mtctr 28
-#elif defined(MODEL_ppc64)
- ld 0, 0(28)
- mtctr 0
- ld 2, 8(28)
-#elif defined(MODEL_ppc64le)
- mtctr 28
- mr 12, 28
-#else
-#error "wrong MODEL"
-#endif
- bctr
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(function "quicksort" (lo: int hi: int a: val)
- (if (< lo hi)
- (let (i lo
- j hi
- pivot (addraref a hi))
- (while (< i j)
- (catch
- (while 1
- (if (>= i hi) exit [])
- (if (> (addraref a i) pivot) exit [])
- (assign i (+ i 1)))
- with [])
- (catch
- (while 1
- (if (<= j lo) exit [])
- (if (< (addraref a j) pivot) exit [])
- (assign j (- j 1)))
- with [])
- (if (< i j)
- (let temp (addraref a i)
- (addraset a i (addraref a j))
- (addraset a j temp))
- []))
- (let temp (addraref a i)
- (addraset a i (addraref a hi))
- (addraset a hi temp))
- (app "quicksort" lo (- i 1) a unit)
- (app "quicksort" (+ i 1) hi a unit))
- []))
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(function "cmp" (i: int j: int)
- (- i j))
-
-(function "quick" (lo: int hi: int a: val cmp: val)
- (if (< lo hi)
- (let (i lo
- j hi
- pivot (intaref a hi))
- (while (< i j)
- (catch
- (while 1
- (if (>= i hi) exit [])
- (if (> (app cmp (intaref a i) pivot int) 0) exit [])
- (assign i (+ i 1)))
- with [])
- (catch
- (while 1
- (if (<= j lo) exit [])
- (if (< (app cmp (intaref a j) pivot int) 0) exit [])
- (assign j (- j 1)))
- with [])
- (if (< i j)
- (let temp (intaref a i)
- (intaset a i (intaref a j))
- (intaset a j temp))
- []))
- (let temp (intaref a i)
- (intaset a i (intaref a hi))
- (intaset a hi temp))
- (app "quick" lo (- i 1) a cmp unit)
- (app "quick" (+ i 1) hi a cmp unit))
- []))
-
-(function "quicksort" (lo: int hi: int a: val)
- (app "quick" lo hi a "cmp" unit))
+(* TEST
+ * native
+*)
+
type 'a typ = Int : int typ | Ptr : int list typ
let f (type a) (t : a typ) (p : int list) : a =
+(* TEST
+ * native
+*)
+
type 'a typ = Int : int typ | Ptr : int list typ | Int2 : int typ
let f (type a) (t : a typ) (p : int list) : a =
+++ /dev/null
-#define ALIGN 8
-
-#define CALL_GEN_CODE call_gen_code
-#define CAML_C_CALL caml_c_call
-#define CAML_NEGF_MASK caml_negf_mask
-#define CAML_ABSF_MASK caml_absf_mask
-
- .section ".text"
-
- .globl CALL_GEN_CODE
- .type CALL_GEN_CODE, @function
- .align ALIGN
-CALL_GEN_CODE:
- /* Stack space */
- lay %r15, -144(%r15)
- /* Save registers */
- stmg %r6,%r14, 0(%r15)
- std %f8, 72(%r15)
- std %f9, 80(%r15)
- std %f10, 88(%r15)
- std %f11, 96(%r15)
- std %f12, 104(%r15)
- std %f13, 112(%r15)
- std %f14, 120(%r15)
- std %f15, 128(%r15)
- /* Shuffle args */
- lgr %r1, %r2
- lgr %r2, %r3
- lgr %r3, %r4
- lgr %r4, %r5
- /* Function call */
- basr %r14, %r1
- /* Restore registers */
- lmg %r6,%r14, 0(%r15)
- ld %f8, 72(%r15)
- ld %f9, 80(%r15)
- ld %f10, 88(%r15)
- ld %f11, 96(%r15)
- ld %f12, 104(%r15)
- ld %f13, 112(%r15)
- ld %f14, 120(%r15)
- ld %f15, 128(%r15)
- /* Return */
- lay %r15, 144(%r15)
- br %r14
-
- .globl CAML_C_CALL
- .type CAML_C_CALL, @function
- .align ALIGN
-CAML_C_CALL:
- br %r7
-
- .section ".rodata"
-
- .global CAML_NEGF_MASK
- .align ALIGN
-CAML_NEGF_MASK:
- .quad 0x8000000000000000, 0
- .global CAML_ABSF_MASK
- .align ALIGN
-CAML_ABSF_MASK:
- .quad 0x7FFFFFFFFFFFFFFF, 0
-
- .comm young_limit, 8
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-("d1": int 0 int 1
- "d2": int 1 int 0
- "d3": int 0 int -1
- "d4": int -1 int 0
- "dir": val "d1" val "d2" val "d3" val "d4")
-
-("counter": int 0)
-
-(* Out = 0 Empty = 1 Peg = 2 *)
-
-("line0": int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0
- "line1": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
- "line2": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
- "line3": int 0 int 2 int 2 int 2 int 2 int 2 int 2 int 2 int 0
- "line4": int 0 int 2 int 2 int 2 int 1 int 2 int 2 int 2 int 0
- "line5": int 0 int 2 int 2 int 2 int 2 int 2 int 2 int 2 int 0
- "line6": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
- "line7": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
- "line8": int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0
- "board": val "line0" val "line1" val "line2" val "line3"
- val "line4" val "line5" val "line6" val "line7" val "line8")
-
-("format": string "%d\n\000")
-
-(function "solve" (m: int)
- (store int "counter" (+ (load int "counter") 1))
- (if (== m 31)
- (== (intaref (addraref "board" 4) 4) 2)
- (try
- (if (== (mod (load int "counter") 500) 0)
- (extcall "printf_int" "format" (load int "counter") unit)
- [])
- (let i 1
- (while (<= i 7)
- (let j 1
- (while (<= j 7)
- (if (== (intaref (addraref "board" i) j) 2)
- (seq
- (let k 0
- (while (<= k 3)
- (let (d1 (intaref (addraref "dir" k) 0)
- d2 (intaref (addraref "dir" k) 1)
- i1 (+ i d1)
- i2 (+ i1 d1)
- j1 (+ j d2)
- j2 (+ j1 d2))
- (if (== (intaref (addraref "board" i1) j1) 2)
- (if (== (intaref (addraref "board" i2) j2) 1)
- (seq
- (intaset (addraref "board" i) j 1)
- (intaset (addraref "board" i1) j1 1)
- (intaset (addraref "board" i2) j2 2)
- (if (app "solve" (+ m 1) int)
- (raise_notrace 0a)
- [])
- (intaset (addraref "board" i) j 2)
- (intaset (addraref "board" i1) j1 2)
- (intaset (addraref "board" i2) j2 1))
- [])
- []))
- (assign k (+ k 1)))))
- [])
- (assign j (+ j 1))))
- (assign i (+ i 1))))
- 0
- with bucket
- 1)))
-
-("format_out": string ".\000")
-("format_empty": string " \000")
-("format_peg": string "$\000")
-("format_newline": string "\n\000")
-
-(function "print_board" ()
- (let i 0
- (while (< i 9)
- (let j 0
- (while (< j 9)
- (switch 3 (intaref (addraref "board" i) j)
- case 0:
- (extcall "print_string" "format_out" unit)
- case 1:
- (extcall "print_string" "format_empty" unit)
- case 2:
- (extcall "print_string" "format_peg" unit))
- (assign j (+ j 1))))
- (extcall "print_string" "format_newline" unit)
- (assign i (+ i 1)))))
-
-(function "solitaire" ()
- (seq
- (if (app "solve" 0 int)
- (app "print_board" [] unit)
- [])
- 0))
+++ /dev/null
-/**************************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. */
-/* */
-/* All rights reserved. This file is distributed under the terms of */
-/* the GNU Lesser General Public License version 2.1, with the */
-/* special exception on linking described in the file LICENSE. */
-/* */
-/**************************************************************************/
-
-#if defined(SYS_solaris) || defined(SYS_linux)
-#define Call_gen_code call_gen_code
-#define Caml_c_call caml_c_call
-#else
-#define Call_gen_code _call_gen_code
-#define Caml_c_call _caml_c_call
-#endif
-
- .global Call_gen_code
-Call_gen_code:
- save %sp, -96, %sp
- mov %i0, %l0
- mov %i1, %i0
- mov %i2, %i1
- mov %i3, %i2
- mov %i4, %i3
- mov %i5, %i4
- call %l0
- nop
- mov %o0, %i0
- ret
- restore
-
- .global Caml_c_call
-Caml_c_call:
- jmp %g4
- nop
+(* TEST
+ modules = "is_in_static_data.c simple_float_const.ml"
+ * flambda
+ ** flat-float-array
+ *** native
+*)
+
external is_in_static_data : 'a -> bool = "caml_is_in_static_data"
let a = [|0.; 1.|]
+(* TEST
+ modules = "is_in_static_data.c simple_float_const_opaque.ml"
+ flags = "-opaque"
+ * flambda
+ ** flat-float-array
+ *** native
+*)
+
external is_in_static_data : 'a -> bool = "caml_is_in_static_data"
let a = [|0.; 1.|]
+(* TEST
+ include config
+ * native
+ flags = "config.cmx"
+*)
+
(* Check the effectiveness of structured constant propagation and
static allocation.
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(function "fib" (n: int)
- (if (< n 5)
- 3
- (- (+ (app "fib" (- n 2) int) (app "fib" (- n 4) int)) 1)))
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-("res_square": skip 8)
-("h": skip 8)
-("x": skip 8)
-("s": skip 8)
-("res_integr": skip 8)
-
-(function "square" (x: val)
- (let r "res_square"
- (store float r ( *f (load float x) (load float x)))
- r))
-
-(function "integr" (f: val low: val high: val n: int)
- (let (h "h" x "x" s "s" i n)
- (store float h (/f (-f (load float high) (load float low)) (floatofint n)))
- (store float x (load float low))
- (store float s 0.0)
- (while (> i 0)
- (store float s (+f (load float s) (load float (app f x val))))
- (store float x (+f (load float x) (load float h)))
- (assign i (- i 1)))
- (store float "res_integr" ( *f (load float s) (load float h)))
- "res_integr"))
-
-("low": skip 8)
-("hi": skip 8)
-
-(function "test" (n: int)
- (store float "low" 0.0)
- (store float "hi" 1.0)
- (load float (app "integr" "square" "low" "hi" n val)))
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(function "quick" (lo: int hi: int a: val)
- (if (< lo hi)
- (let (i lo
- j hi
- pivot (addraref a (>>s hi 1)))
- (while (< i j)
- (catch
- (while 1
- (if (>= i hi) exit [])
- (if (> (addraref a (>>s i 1)) pivot) exit [])
- (assign i (+ i 2)))
- with [])
- (catch
- (while 1
- (if (<= j lo) exit [])
- (if (< (addraref a (>>s j 1)) pivot) exit [])
- (assign j (- j 2)))
- with [])
- (if (< i j)
- (let temp (addraref a (>>s i 1))
- (addraset a (>>s i 1) (addraref a (>>s j 1)))
- (addraset a (>>s j 1) temp))
- []))
- (let temp (addraref a (>>s i 1))
- (addraset a (>>s i 1) (addraref a (>>s hi 1)))
- (addraset a (>>s hi 1) temp))
- (app "quick" lo (- i 2) a unit)
- (app "quick" (+ i 2) hi a unit))
- []))
-
-(function "quicksort" (lo: int hi: int a: val)
- (app "quick" (+ (<< lo 1) 1) (+ (<< hi 1) 1) a unit))
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(function "tak" (x:int y:int z:int)
- (if (> x y)
- (app "tak" (app "tak" (- x 2) y z int)
- (app "tak" (- y 2) z x int)
- (app "tak" (- z 2) x y int) int)
- z))
-
-(function "takmain" (dummy: int)
- (app "tak" 37 25 13 int))
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(function "tak" (x:int y:int z:int)
- (if (> x y)
- (app "tak" (app "tak" (- x 1) y z int)
- (app "tak" (- y 1) z x int)
- (app "tak" (- z 1) x y int) int)
- z))
-
-(function "takmain" (dummy: int)
- (app "tak" 18 12 6 int))
+(* TEST
+ * flambda
+ ** native
+*)
let rec f x =
if x > 0 then f (x - 1)
+(* TEST
+ * flambda
+ ** native
+*)
type t = { fn : t -> t -> int -> unit -> unit }
--- /dev/null
+#**************************************************************************
+#* *
+#* OCaml *
+#* *
+#* Xavier Clerc, SED, INRIA Rocquencourt *
+#* *
+#* Copyright 2010 Institut National de Recherche en Informatique et *
+#* en Automatique. *
+#* *
+#* All rights reserved. This file is distributed under the terms of *
+#* the GNU Lesser General Public License version 2.1, with the *
+#* special exception on linking described in the file LICENSE. *
+#* *
+#**************************************************************************
+
+BASEDIR=../..
+
+include $(BASEDIR)/../config/Makefile
+
+INCLUDES=\
+ -I $(OTOPDIR)/parsing \
+ -I $(OTOPDIR)/utils \
+ -I $(OTOPDIR)/typing \
+ -I $(OTOPDIR)/middle_end \
+ -I $(OTOPDIR)/bytecomp \
+ -I $(OTOPDIR)/asmcomp
+
+OTHEROBJS=\
+ $(OTOPDIR)/compilerlibs/ocamlcommon.cma \
+ $(OTOPDIR)/compilerlibs/ocamloptcomp.cma
+
+OBJS=parsecmmaux.cmo parsecmm.cmo lexcmm.cmo
+
+ADD_COMPFLAGS=$(INCLUDES) -w -40 -g
+
+default:
+ @if $(BYTECODE_ONLY) || $(SKIP) ; then $(MAKE) skips ; else \
+ $(MAKE) all; \
+ fi
+
+all:
+ @$(MAKE) arch codegen
+ @$(MAKE) tests
+
+main.cmo: parsecmm.cmo
+
+codegen: parsecmm.ml lexcmm.ml $(OBJS:.cmo=.cmi) $(OBJS) main.cmo
+ @$(OCAMLC) $(LINKFLAGS) -o codegen $(OTHEROBJS) $(OBJS) main.cmo
+
+parsecmm.mli parsecmm.ml: parsecmm.mly
+ @$(OCAMLYACC) -q parsecmm.mly
+
+lexcmm.ml: lexcmm.mll
+ @$(OCAMLLEX) -q lexcmm.mll
+
+CASES=fib tak quicksort quicksort2 soli \
+ arith checkbound tagged-fib tagged-integr tagged-quicksort tagged-tak \
+ catch-try catch-rec even-odd even-odd-spill pgcd
+ARGS_fib=-DINT_INT -DFUN=fib main.c
+ARGS_tak=-DUNIT_INT -DFUN=takmain main.c
+ARGS_quicksort=-DSORT -DFUN=quicksort main.c
+ARGS_quicksort2=-DSORT -DFUN=quicksort main.c
+ARGS_soli=-DUNIT_INT -DFUN=solitaire main.c
+ARGS_integr=-DINT_FLOAT -DFUN=test main.c
+ARGS_arith=mainarith.c
+ARGS_checkbound=-DCHECKBOUND main.c
+ARGS_tagged-fib=-DINT_INT -DFUN=fib main.c
+ARGS_tagged-integr=-DINT_FLOAT -DFUN=test main.c
+ARGS_tagged-quicksort=-DSORT -DFUN=quicksort main.c
+ARGS_tagged-tak=-DUNIT_INT -DFUN=takmain main.c
+ARGS_catch-try=-DINT_INT -DFUN=catch_exit main.c
+ARGS_catch-rec=-DINT_INT -DFUN=catch_fact main.c
+ARGS_even-odd=-DINT_INT -DFUN=is_even main.c
+ARGS_even-odd-spill=-DINT_INT -DFUN=is_even main.c
+ARGS_pgcd=-DINT_INT -DFUN=pgcd_30030 main.c
+
+skips:
+ @for c in $(CASES); do \
+ echo " ... testing '$$c': => skipped"; \
+ done
+
+one:
+ @$(call CCOMP,$(NAME).out $(ARGS_$(NAME)) $(NAME).$(O) $(ARCH).$(O)) \
+ && echo " => passed" || echo " => failed"
+
+clean: defaultclean
+ @rm -f ./codegen *.out *.out.manifest *.$(O) *.exe
+ @rm -f parsecmm.ml parsecmm.mli lexcmm.ml
+ @rm -f $(CASES:=.s)
+
+include $(BASEDIR)/makefiles/Makefile.common
+
+ifeq "$(CCOMPTYPE)-$(ARCH)" "msvc-amd64"
+# these tests are not ported to MSVC64 yet
+SKIP=true
+else
+SKIP=false
+endif
+
+ifeq "$(WITH_SPACETIME)" "true"
+# These tests have not been ported for Spacetime
+SKIP=true
+endif
+
+ifeq ($(CCOMPTYPE),msvc)
+CCOMP=set -o pipefail ; $(CC) $(CFLAGS) /Fe$(1) | tail -n +2
+else
+CCOMP=$(CC) $(CFLAGS) -o $(1)
+endif
+tests: $(CASES:=.$(O))
+ @for c in $(CASES); do \
+ printf " ... testing '$$c':"; \
+ $(MAKE) one NAME=$$c; \
+ done
+
+promote:
+
+arch: $(ARCH).$(O)
+
+i386.obj: i386nt.asm
+ @set -o pipefail ; \
+ $(ASM) $@ $^ | tail -n +2
--- /dev/null
+/**************************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 2000 Institut National de Recherche en Informatique et */
+/* en Automatique. */
+/* */
+/* All rights reserved. This file is distributed under the terms of */
+/* the GNU Lesser General Public License version 2.1, with the */
+/* special exception on linking described in the file LICENSE. */
+/* */
+/**************************************************************************/
+
+#ifdef SYS_macosx
+#define ALIGN 4
+#else
+#define ALIGN 16
+#endif
+
+#ifdef SYS_macosx
+#define CALL_GEN_CODE _call_gen_code
+#define CAML_C_CALL _caml_c_call
+#define CAML_NEGF_MASK _caml_negf_mask
+#define CAML_ABSF_MASK _caml_absf_mask
+#else
+#define CALL_GEN_CODE call_gen_code
+#define CAML_C_CALL caml_c_call
+#define CAML_NEGF_MASK caml_negf_mask
+#define CAML_ABSF_MASK caml_absf_mask
+#endif
+
+ .globl CALL_GEN_CODE
+ .align ALIGN
+CALL_GEN_CODE:
+ pushq %rbx
+ pushq %rbp
+ pushq %r12
+ pushq %r13
+ pushq %r14
+ pushq %r15
+ movq %rdi, %r10
+ movq %rsi, %rax
+ movq %rdx, %rbx
+ movq %rcx, %rdi
+ movq %r8, %rsi
+ call *%r10
+ popq %r15
+ popq %r14
+ popq %r13
+ popq %r12
+ popq %rbp
+ popq %rbx
+ ret
+
+ .globl CAML_C_CALL
+ .align ALIGN
+CAML_C_CALL:
+ jmp *%rax
+
+#ifdef SYS_macosx
+ .literal16
+#elif defined(SYS_mingw64) || defined(SYS_cygwin)
+ .section .rodata.cst8
+#else
+ .section .rodata.cst8,"aM",@progbits,8
+#endif
+ .globl CAML_NEGF_MASK
+ .align ALIGN
+CAML_NEGF_MASK:
+ .quad 0x8000000000000000, 0
+ .globl CAML_ABSF_MASK
+ .align ALIGN
+CAML_ABSF_MASK:
+ .quad 0x7FFFFFFFFFFFFFFF, 0
+
+ .comm young_limit, 8
+
+#if defined(SYS_linux)
+ /* Mark stack as non-executable */
+ .section .note.GNU-stack,"",%progbits
+#endif
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Regression test for arithmetic instructions *)
+
+(function "testarith" ()
+ (let r "R"
+ (let d "D"
+ (let x (load int "X")
+ (let y (load int "Y")
+ (let f (load float "F")
+ (let g (load float "G")
+ (addraset r 0 0)
+ (addraset r 1 1)
+ (addraset r 2 -1)
+ (addraset r 3 256)
+ (addraset r 4 65536)
+ (addraset r 5 16777216)
+ (addraset r 6 -256)
+ (addraset r 7 -65536)
+ (addraset r 8 -16777216)
+
+ (addraset r 9 (+ x y))
+ (addraset r 10 (+ x 1))
+ (addraset r 11 (+ x -1))
+
+ (addraset r 12 (+a "R" 8))
+ (addraset r 13 (+a "R" y))
+
+ (addraset r 14 (- x y))
+ (addraset r 15 (- x 1))
+ (addraset r 16 (- x -1))
+
+ (addraset r 17 (- "R" 8))
+ (addraset r 18 (- "R" y))
+
+ (addraset r 19 ( * x 2))
+ (addraset r 20 ( * 2 x))
+ (addraset r 21 ( * x 16))
+ (addraset r 22 ( * 16 x))
+ (addraset r 23 ( * x 12345))
+ (addraset r 24 ( * 12345 x))
+ (addraset r 25 ( * x y))
+
+ (addraset r 26 (/ x 2))
+ (addraset r 27 (/ x 16))
+ (addraset r 28 (/ x 7))
+ (addraset r 29 (if (!= y 0) (/ x y) 0))
+
+ (addraset r 30 (mod x 2))
+ (addraset r 31 (mod x 16))
+ (addraset r 32 (if (!= y 0) (mod x y) 0))
+
+ (addraset r 33 (and x y))
+ (addraset r 34 (and x 3))
+ (addraset r 35 (and 3 x))
+
+ (addraset r 36 (or x y))
+ (addraset r 37 (or x 3))
+ (addraset r 38 (or 3 x))
+
+ (addraset r 39 (xor x y))
+ (addraset r 40 (xor x 3))
+ (addraset r 41 (xor 3 x))
+
+ (addraset r 42 (<< x y))
+ (addraset r 43 (<< x 1))
+ (addraset r 44 (<< x 8))
+
+ (addraset r 45 (>>u x y))
+ (addraset r 46 (>>u x 1))
+ (addraset r 47 (>>u x 8))
+
+ (addraset r 48 (>>s x y))
+ (addraset r 49 (>>s x 1))
+ (addraset r 50 (>>s x 8))
+
+ (addraset r 51 (== x y))
+ (addraset r 52 (!= x y))
+ (addraset r 53 (< x y))
+ (addraset r 54 (> x y))
+ (addraset r 55 (<= x y))
+ (addraset r 56 (>= x y))
+ (addraset r 57 (== x 1))
+ (addraset r 58 (!= x 1))
+ (addraset r 59 (< x 1))
+ (addraset r 60 (> x 1))
+ (addraset r 61 (<= x 1))
+ (addraset r 62 (>= x 1))
+
+ (addraset r 63 (==a x y))
+ (addraset r 64 (!=a x y))
+ (addraset r 65 (<a x y))
+ (addraset r 66 (>a x y))
+ (addraset r 67 (<=a x y))
+ (addraset r 68 (>=a x y))
+ (addraset r 69 (==a x 1))
+ (addraset r 70 (!=a x 1))
+ (addraset r 71 (<a x 1))
+ (addraset r 72 (>a x 1))
+ (addraset r 73 (<=a x 1))
+ (addraset r 74 (>=a x 1))
+
+ (addraset r 75 (+ x (<< y 1)))
+ (addraset r 76 (+ x (<< y 2)))
+ (addraset r 77 (+ x (<< y 3)))
+ (addraset r 78 (- x (<< y 1)))
+ (addraset r 79 (- x (<< y 2)))
+ (addraset r 80 (- x (<< y 3)))
+
+ (floataset d 0 0.0)
+ (floataset d 1 1.0)
+ (floataset d 2 -1.0)
+ (floataset d 3 (+f f g))
+ (floataset d 4 (-f f g))
+ (floataset d 5 ( *f f g))
+ (floataset d 6 (/f f g))
+
+ (floataset d 7 (+f f (+f g 1.0)))
+ (floataset d 8 (-f f (+f g 1.0)))
+ (floataset d 9 ( *f f (+f g 1.0)))
+ (floataset d 10 (/f f (+f g 1.0)))
+
+ (floataset d 11 (+f (+f f 1.0) g))
+ (floataset d 12 (-f (+f f 1.0) g))
+ (floataset d 13 ( *f (+f f 1.0) g))
+ (floataset d 14 (/f (+f f 1.0) g))
+
+ (floataset d 15 (+f (+f f 1.0) (+f g 1.0)))
+ (floataset d 16 (-f (+f f 1.0) (+f g 1.0)))
+ (floataset d 17 ( *f (+f f 1.0) (+f g 1.0)))
+ (floataset d 18 (/f (+f f 1.0) (+f g 1.0)))
+
+ (addraset r 81 (==f f g))
+ (addraset r 82 (!=f f g))
+ (addraset r 83 (<f f g))
+ (addraset r 84 (>f f g))
+ (addraset r 85 (<=f f g))
+ (addraset r 86 (>=f f g))
+
+ (floataset d 19 (floatofint x))
+ (addraset r 87 (intoffloat f))
+
+ (if (and (>= x 0) (< x y))
+ (seq (checkbound y x) (addraset r 88 1))
+ (addraset r 88 0))
+
+ (if (< 0 y)
+ (seq (checkbound y 0) (addraset r 89 1))
+ (addraset r 89 0))
+
+ (if (< 5 y)
+ (seq (checkbound y 5) (addraset r 90 1))
+ (addraset r 90 0))
+
+ (addraset r 91 (let res 1 (if (==f f g) [] (assign res 0)) res))
+ (addraset r 92 (let res 1 (if (!=f f g) [] (assign res 0)) res))
+ (addraset r 93 (let res 1 (if (<f f g) [] (assign res 0)) res))
+ (addraset r 94 (let res 1 (if (>f f g) [] (assign res 0)) res))
+ (addraset r 95 (let res 1 (if (<=f f g) [] (assign res 0)) res))
+ (addraset r 96 (let res 1 (if (>=f f g) [] (assign res 0)) res))
+
+ (addraset r 97 (==f (+f f 1.0) (+f g 1.0)))
+ (addraset r 98 (!=f (+f f 1.0) (+f g 1.0)))
+ (addraset r 99 (<f (+f f 1.0) (+f g 1.0)))
+ (addraset r 100 (>f (+f f 1.0) (+f g 1.0)))
+ (addraset r 101 (<=f (+f f 1.0) (+f g 1.0)))
+ (addraset r 102 (>=f (+f f 1.0) (+f g 1.0)))
+
+ (addraset r 103 (==f f (+f g 1.0)))
+ (addraset r 104 (!=f f (+f g 1.0)))
+ (addraset r 105 (<f f (+f g 1.0)))
+ (addraset r 106 (>f f (+f g 1.0)))
+ (addraset r 107 (<=f f (+f g 1.0)))
+ (addraset r 108 (>=f f (+f g 1.0)))
+
+ (addraset r 109 (==f (+f f 1.0) g))
+ (addraset r 110 (!=f (+f f 1.0) g))
+ (addraset r 111 (<f (+f f 1.0) g))
+ (addraset r 112 (>f (+f f 1.0) g))
+ (addraset r 113 (<=f (+f f 1.0) g))
+ (addraset r 114 (>=f (+f f 1.0) g))
+
+ (floataset d 20 (+f (floatofint x) 1.0))
+ (addraset r 115 (intoffloat (+f f 1.0)))
+
+ (floataset d 21 (+f f (load float "G")))
+ (floataset d 22 (+f (load float "G") f))
+ (floataset d 23 (-f f (load float "G")))
+ (floataset d 24 (-f (load float "G") f))
+ (floataset d 25 ( *f f (load float "G")))
+ (floataset d 26 ( *f (load float "G") f))
+ (floataset d 27 (/f f (load float "G")))
+ (floataset d 28 (/f (load float "G") f))
+
+ (floataset d 29 (+f ( *f f 2.0) (load float "G")))
+ (floataset d 30 (+f (load float "G") ( *f f 2.0)))
+ (floataset d 31 (-f ( *f f 2.0) (load float "G")))
+ (floataset d 32 (-f (load float "G") ( *f f 2.0)))
+ (floataset d 33 ( *f ( +f f 2.0) (load float "G")))
+ (floataset d 34 ( *f (load float "G") ( +f f 2.0)))
+ (floataset d 35 (/f ( *f f 2.0) (load float "G")))
+ (floataset d 36 (/f (load float "G") ( *f f 2.0)))
+
+ (floataset d 37 (-f f))
+ (floataset d 38 (absf f))
+
+ (addraset r 116 (mulh x y))
+)))))))
--- /dev/null
+/**************************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 1998 Institut National de Recherche en Informatique et */
+/* en Automatique. */
+/* */
+/* All rights reserved. This file is distributed under the terms of */
+/* the GNU Lesser General Public License version 2.1, with the */
+/* special exception on linking described in the file LICENSE. */
+/* */
+/**************************************************************************/
+
+ .text
+
+ .global call_gen_code
+ .type call_gen_code, %function
+ .align 0
+call_gen_code:
+ mov ip, sp
+ stmfd sp!, {r4, r5, r6, r7, r8, r9, fp, ip, lr, pc}
+ sub fp, ip, #4
+ @ r0 is function to call
+ @ r1, r2, r3 are arguments 1, 2, 3
+ mov r4, r0
+ mov r0, r1
+ mov r1, r2
+ mov r2, r3
+ blx r4
+ ldmea fp, {r4, r5, r6, r7, r8, r9, fp, sp, pc}
+
+ .global caml_c_call
+ .type caml_c_call, %function
+ .align 0
+caml_c_call:
+ @ function to call is in r10
+ bx r10
+
+/* Mark stack as non-executable */
+ .section .note.GNU-stack,"",%progbits
--- /dev/null
+/**************************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */
+/* */
+/* Copyright 2013 Institut National de Recherche en Informatique et */
+/* en Automatique. */
+/* */
+/* All rights reserved. This file is distributed under the terms of */
+/* the GNU Lesser General Public License version 2.1, with the */
+/* special exception on linking described in the file LICENSE. */
+/* */
+/**************************************************************************/
+
+ .globl call_gen_code
+ .align 2
+call_gen_code:
+ /* Set up stack frame and save callee-save registers */
+ stp x29, x30, [sp, -160]!
+ add x29, sp, #0
+ stp x19, x20, [sp, 16]
+ stp x21, x22, [sp, 32]
+ stp x23, x24, [sp, 48]
+ stp x25, x26, [sp, 64]
+ stp x27, x28, [sp, 80]
+ stp d8, d9, [sp, 96]
+ stp d10, d11, [sp, 112]
+ stp d12, d13, [sp, 128]
+ stp d14, d15, [sp, 144]
+ /* Shuffle arguments */
+ mov x8, x0
+ mov x0, x1
+ mov x1, x2
+ mov x2, x3
+ mov x3, x4
+ /* Call generated asm */
+ blr x8
+ /* Reload callee-save registers and return address */
+ ldp x19, x20, [sp, 16]
+ ldp x21, x22, [sp, 32]
+ ldp x23, x24, [sp, 48]
+ ldp x25, x26, [sp, 64]
+ ldp x27, x28, [sp, 80]
+ ldp d8, d9, [sp, 96]
+ ldp d10, d11, [sp, 112]
+ ldp d12, d13, [sp, 128]
+ ldp d14, d15, [sp, 144]
+ ldp x29, x30, [sp], 160
+ ret
+
+ .globl caml_c_call
+ .align 2
+caml_c_call:
+ br x15
+
+/* Mark stack as non-executable */
+ .section .note.GNU-stack,"",%progbits
--- /dev/null
+(function "catch_fact" (b:int)
+ (catch (exit fact b 1)
+ with (fact c acc)
+ (if (== c 0) acc
+ (exit fact (- c 1) ( * c acc)))))
--- /dev/null
+
+(function "catch_exit" (b:int)
+ (+ 33
+ (catch
+ (try (exit lbl 12)
+ with var 456)
+ with (lbl x) (+ x 789))))
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(function "checkbound2" (x: int y: int)
+ (checkbound x y))
+
+(function "checkbound1" (x: int)
+ (checkbound x 2))
--- /dev/null
+("format_odd": string "odd %d\n\000")
+("format_even": string "even %d\n\000")
+
+(function "force_spill" (a:int) 0)
+
+(function "is_even" (b:int)
+ (catch (exit even b)
+ with (odd v)
+ (if (== v 0) 0
+ (seq
+ (extcall "printf_int" "format_odd" v unit)
+ (let v2 (- v 1)
+ (app "force_spill" 0 int)
+ (exit even v2))))
+ and (even v)
+ (if (== v 0) 1
+ (seq
+ (extcall "printf_int" "format_even" v unit)
+ (exit odd (- v 1))))))
--- /dev/null
+(function "is_even" (b:int)
+ (catch (exit even b)
+ with (odd v)
+ (if (== v 0) 0
+ (exit even (- v 1)))
+ and (even v)
+ (if (== v 0) 1
+ (exit odd (- v 1)))))
\ No newline at end of file
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(function "fib" (n: int)
+ (if (< n 2)
+ 1
+ (+ (app "fib" (- n 1) int)
+ (app "fib" (- n 2) int))))
--- /dev/null
+/**************************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 1996 Institut National de Recherche en Informatique et */
+/* en Automatique. */
+/* */
+/* All rights reserved. This file is distributed under the terms of */
+/* the GNU Lesser General Public License version 2.1, with the */
+/* special exception on linking described in the file LICENSE. */
+/* */
+/**************************************************************************/
+
+/* Linux with ELF binaries does not prefix identifiers with _.
+ Linux with a.out binaries, FreeBSD, and NextStep do. */
+
+#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \
+ || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_gnu)
+#define G(x) x
+#define FUNCTION_ALIGN 16
+#else
+#define G(x) _##x
+#define FUNCTION_ALIGN 4
+#endif
+
+ .globl G(call_gen_code)
+ .align FUNCTION_ALIGN
+G(call_gen_code):
+ pushl %ebp
+ movl %esp,%ebp
+ pushl %ebx
+ pushl %esi
+ pushl %edi
+ movl 12(%ebp),%eax
+ movl 16(%ebp),%ebx
+ movl 20(%ebp),%ecx
+ movl 24(%ebp),%edx
+ call *8(%ebp)
+ popl %edi
+ popl %esi
+ popl %ebx
+ popl %ebp
+ ret
+
+ .globl G(caml_c_call)
+ .align FUNCTION_ALIGN
+G(caml_c_call):
+ jmp *%eax
+
+ .comm G(caml_exception_pointer), 4
+ .comm G(young_ptr), 4
+ .comm G(young_start), 4
+
+#if defined(SYS_linux_elf)
+ /* Mark stack as non-executable */
+ .section .note.GNU-stack,"",%progbits
+#endif
--- /dev/null
+;*********************************************************************;
+; ;
+; OCaml ;
+; ;
+; Xavier Leroy, projet Cristal, INRIA Rocquencourt ;
+; ;
+; Copyright 1996 Institut National de Recherche en Informatique et ;
+; en Automatique. All rights reserved. This file is distributed ;
+; under the terms of the Q Public License version 1.0. ;
+; ;
+;*********************************************************************;
+
+ .386
+ .MODEL FLAT
+
+ .CODE
+ PUBLIC _call_gen_code
+ ALIGN 4
+_call_gen_code:
+ push ebp
+ mov ebp, esp
+ push ebx
+ push esi
+ push edi
+ mov eax, [ebp+12]
+ mov ebx, [ebp+16]
+ mov ecx, [ebp+20]
+ mov edx, [ebp+24]
+ call DWORD PTR [ebp+8]
+ pop edi
+ pop esi
+ pop ebx
+ pop ebp
+ ret
+
+ PUBLIC _caml_c_call
+ ALIGN 4
+_caml_c_call:
+ ffree st(0)
+ ffree st(1)
+ ffree st(2)
+ ffree st(3)
+ jmp eax
+
+ PUBLIC _caml_call_gc
+ PUBLIC _caml_alloc
+ PUBLIC _caml_alloc1
+ PUBLIC _caml_alloc2
+ PUBLIC _caml_alloc3
+_caml_call_gc:
+_caml_alloc:
+_caml_alloc1:
+_caml_alloc2:
+_caml_alloc3:
+ int 3
+
+ .DATA
+ PUBLIC _caml_exception_pointer
+_caml_exception_pointer dword 0
+ PUBLIC _young_ptr
+_young_ptr dword 0
+ PUBLIC _young_limit
+_young_limit dword 0
+
+ END
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(function "square" (x: float)
+ ( *f x x))
+
+(function "integr" (f: addr low: float high: float n: int)
+ (let (h (/f (-f high low) (floatofint n))
+ x low
+ s 0.0
+ i n)
+ (while (> i 0)
+ (assign s (+f s (app f x float)))
+ (assign x (+f x h))
+ (assign i (- i 1)))
+ ( *f s h)))
+
+(function "test" (n: int)
+ (app "integr" "square" 0.0 1.0 n float))
--- /dev/null
+val token: Lexing.lexbuf -> Parsecmm.token
+
+type error =
+ Illegal_character
+ | Unterminated_comment
+ | Unterminated_string
+
+exception Error of error
+
+val report_error: Lexing.lexbuf -> error -> unit
--- /dev/null
+{
+open Parsecmm
+
+type error =
+ Illegal_character
+ | Unterminated_comment
+ | Unterminated_string
+
+exception Error of error
+
+(* For nested comments *)
+
+let comment_depth = ref 0
+
+(* The table of keywords *)
+
+let keyword_table =
+ Misc.create_hashtable 149 [
+ "absf", ABSF;
+ "addr", ADDR;
+ "align", ALIGN;
+ "alloc", ALLOC;
+ "and", AND;
+ "app", APPLY;
+ "assign", ASSIGN;
+ "byte", BYTE;
+ "case", CASE;
+ "catch", CATCH;
+ "checkbound", CHECKBOUND;
+ "data", DATA;
+ "exit", EXIT;
+ "extcall", EXTCALL;
+ "float", FLOAT;
+ "float32", FLOAT32;
+ "float64", FLOAT64;
+ "floatofint", FLOATOFINT;
+ "function", FUNCTION;
+ "global", GLOBAL;
+ "half", HALF;
+ "if", IF;
+ "int", INT;
+ "int32", INT32;
+ "intoffloat", INTOFFLOAT;
+ "string", KSTRING;
+ "let", LET;
+ "load", LOAD;
+ "mod", MODI;
+ "mulh", MULH;
+ "or", OR;
+ "proj", PROJ;
+ "raise_withtrace", RAISE Cmm.Raise_withtrace;
+ "raise_notrace", RAISE Cmm.Raise_notrace;
+ "seq", SEQ;
+ "signed", SIGNED;
+ "skip", SKIP;
+ "store", STORE;
+ "switch", SWITCH;
+ "try", TRY;
+ "unit", UNIT;
+ "unsigned", UNSIGNED;
+ "val", VAL;
+ "while", WHILE;
+ "with", WITH;
+ "xor", XOR;
+ "addraref", ADDRAREF;
+ "intaref", INTAREF;
+ "floataref", FLOATAREF;
+ "addraset", ADDRASET;
+ "intaset", INTASET;
+ "floataset", FLOATASET
+]
+
+(* To buffer string literals *)
+
+let initial_string_buffer = Bytes.create 256
+let string_buff = ref initial_string_buffer
+let string_index = ref 0
+
+let reset_string_buffer () =
+ string_buff := initial_string_buffer;
+ string_index := 0
+
+let store_string_char c =
+ if !string_index >= Bytes.length (!string_buff) then begin
+ let new_buff = Bytes.create (Bytes.length (!string_buff) * 2) in
+ Bytes.blit (!string_buff) 0 new_buff 0 (Bytes.length (!string_buff));
+ string_buff := new_buff
+ end;
+ Bytes.unsafe_set (!string_buff) (!string_index) c;
+ incr string_index
+
+let get_stored_string () =
+ let s = Bytes.sub_string (!string_buff) 0 (!string_index) in
+ string_buff := initial_string_buffer;
+ s
+
+(* To translate escape sequences *)
+
+let char_for_backslash = function
+ 'n' -> '\010'
+ | 'r' -> '\013'
+ | 'b' -> '\008'
+ | 't' -> '\009'
+ | c -> c
+
+let char_for_decimal_code lexbuf i =
+ Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
+ 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) +
+ (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48))
+
+(* Error report *)
+
+let report_error lexbuf msg =
+ prerr_string "Lexical error around character ";
+ prerr_int (Lexing.lexeme_start lexbuf);
+ match msg with
+ Illegal_character ->
+ prerr_string ": illegal character"
+ | Unterminated_comment ->
+ prerr_string ": unterminated comment"
+ | Unterminated_string ->
+ prerr_string ": unterminated string"
+
+}
+
+let newline = ('\013'* '\010')
+
+rule token = parse
+ newline
+ { Lexing.new_line lexbuf; token lexbuf }
+ | [' ' '\009' '\012'] +
+ { token lexbuf }
+ | "+a" { ADDA }
+ | "+v" { ADDV }
+ | "+f" { ADDF }
+ | "+" { ADDI }
+ | ">>s" { ASR }
+ | ":" { COLON }
+ | "/f" { DIVF }
+ | "/" { DIVI }
+ | eof { EOF }
+ | "==a" { EQA }
+ | "==f" { EQF }
+ | "==" { EQI }
+ | ">=a" { GEA }
+ | ">=f" { GEF }
+ | ">=" { GEI }
+ | ">a" { GTA }
+ | ">f" { GTF }
+ | ">" { GTI }
+ | "[" { LBRACKET }
+ | "<=a" { LEA }
+ | "<=f" { LEF }
+ | "<=" { LEI }
+ | "(" { LPAREN }
+ | "<<" { LSL }
+ | ">>u" { LSR }
+ | "<a" { LTA }
+ | "<f" { LTF }
+ | "<" { LTI }
+ | "*f" { MULF }
+ | "*" { STAR }
+ | "!=a" { NEA }
+ | "!=f" { NEF }
+ | "!=" { NEI }
+ | "!>=f" { NGEF }
+ | "!>f" { NGTF }
+ | "!<=f" { NLEF }
+ | "!<f" { NLTF }
+ | "]" { RBRACKET }
+ | ")" { RPAREN }
+ | "-f" { SUBF }
+ | "-" { SUBI }
+ | '-'? (['0'-'9']+ | "0x" ['0'-'9' 'a'-'f' 'A'-'F']+
+ | "0o" ['0'-'7']+ | "0b" ['0'-'1']+)
+ { INTCONST(int_of_string(Lexing.lexeme lexbuf)) }
+ | '-'? ['0'-'9']+ 'a'
+ { let s = Lexing.lexeme lexbuf in
+ POINTER(int_of_string(String.sub s 0 (String.length s - 1))) }
+ | '-'? ['0'-'9']+ ('.' ['0'-'9']*)? (['e' 'E'] ['+' '-']? ['0'-'9']+)?
+ { FLOATCONST(Lexing.lexeme lexbuf) }
+ | ['A'-'Z' 'a'-'z' '\223'-'\246' '\248'-'\255' ]
+ (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255'
+ '\'' '0'-'9' ]) * '/'? (['0'-'9'] *)
+ { let s = Lexing.lexeme lexbuf in
+ try
+ Hashtbl.find keyword_table s
+ with Not_found ->
+ IDENT s }
+ | "\""
+ { reset_string_buffer();
+ string lexbuf;
+ STRING (get_stored_string()) }
+ | "(*"
+ { comment_depth := 1;
+ comment lexbuf;
+ token lexbuf }
+ | '{' ['A' - 'Z' 'a'-'z' '/' ',' '.' '-' '_' ' ''0'-'9']+
+ ':' [ '0'-'9' ]+ ',' ['0'-'9' ]+ '-' ['0'-'9' ]+ '}'
+ {
+ let loc_s = Lexing.lexeme lexbuf in
+ let pos_fname, pos_lnum, start, end_ =
+ Scanf.sscanf loc_s "{%s@:%i,%i-%i}" (fun file line start end_ ->
+ (file, line, start, end_))
+ in
+ let loc_start =
+ Lexing.{ pos_fname; pos_lnum; pos_bol = 0; pos_cnum = start }
+ in
+ let loc_end =
+ Lexing.{ pos_fname; pos_lnum; pos_bol = 0; pos_cnum = end_ }
+ in
+ let location = Location.{ loc_start; loc_end; loc_ghost = false } in
+ LOCATION location }
+ | _ { raise(Error(Illegal_character)) }
+
+and comment = parse
+ "(*"
+ { comment_depth := succ !comment_depth; comment lexbuf }
+ | "*)"
+ { comment_depth := pred !comment_depth;
+ if !comment_depth > 0 then comment lexbuf }
+ | eof
+ { raise (Error(Unterminated_comment)) }
+ | newline
+ { Lexing.new_line lexbuf; comment lexbuf }
+ | _
+ { comment lexbuf }
+
+and string = parse
+ '"'
+ { () }
+ | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] +
+ { string lexbuf }
+ | '\\' ['\\' '"' 'n' 't' 'b' 'r']
+ { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
+ string lexbuf }
+ | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
+ { store_string_char(char_for_decimal_code lexbuf 1);
+ string lexbuf }
+ | eof
+ { raise (Error(Unterminated_string)) }
+ | _
+ { store_string_char(Lexing.lexeme_char lexbuf 0);
+ string lexbuf }
+
--- /dev/null
+/**************************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 1996 Institut National de Recherche en Informatique et */
+/* en Automatique. */
+/* */
+/* All rights reserved. This file is distributed under the terms of */
+/* the GNU Lesser General Public License version 2.1, with the */
+/* special exception on linking described in the file LICENSE. */
+/* */
+/**************************************************************************/
+
+#include <stddef.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <time.h>
+
+void caml_ml_array_bound_error(void)
+{
+ fprintf(stderr, "Fatal error: out-of-bound access in array or string\n");
+ exit(2);
+}
+
+void print_string(char * s)
+{
+ fputs(s, stdout);
+}
+
+void printf_int(char * fmt, int arg)
+{
+ printf(fmt, arg);
+}
+
+#ifdef SORT
+
+int cmpint(const void * i, const void * j)
+{
+ long vi = *((long *) i);
+ long vj = *((long *) j);
+ if (vi == vj) return 0;
+ if (vi < vj) return -1;
+ return 1;
+}
+
+#endif
+
+int main(int argc, char **argv)
+{
+#ifdef UNIT_INT
+ { extern long FUN(void);
+ extern long call_gen_code(long (*)(void));
+ printf("%ld\n", call_gen_code(FUN));
+ }
+#else
+ if (argc < 2) {
+ fprintf(stderr, "Usage: %s [int arg]\n", argv[0]);
+ exit(2);
+ }
+#ifdef INT_INT
+ { extern long FUN(long);
+ extern long call_gen_code(long (*)(long), long);
+ printf("%ld\n", call_gen_code(FUN, atoi(argv[1])));
+ }
+#endif
+#ifdef INT_FLOAT
+ { extern double FUN(long);
+ extern double call_gen_code(double (*)(long), long);
+ printf("%f\n", call_gen_code(FUN, atoi(argv[1])));
+ }
+#endif
+#ifdef SORT
+ { extern void FUN(long, long, long *);
+ extern void call_gen_code(void (*)(long, long, long *), long, long, long *);
+ long n;
+ long * a, * b;
+ long i;
+
+ srand(argc >= 3 ? atoi(argv[2]) : time((time_t *) 0));
+ n = atoi(argv[1]);
+ a = (long *) malloc(n * sizeof(long));
+ for (i = 0 ; i < n; i++) a[i] = rand() & 0xFFF;
+#ifdef DEBUG
+ for (i = 0; i < n; i++) printf("%ld ", a[i]); printf("\n");
+#endif
+ b = (long *) malloc(n * sizeof(long));
+ for (i = 0; i < n; i++) b[i] = a[i];
+ call_gen_code(FUN, 0, n-1, a);
+#ifdef DEBUG
+ for (i = 0; i < n; i++) printf("%ld ", a[i]); printf("\n");
+#endif
+ qsort(b, n, sizeof(long), cmpint);
+ for (i = 0; i < n; i++) {
+ if (a[i] != b[i]) { printf("Bug!\n"); return 2; }
+ }
+ printf("OK\n");
+ }
+#endif
+#endif
+#ifdef CHECKBOUND
+ { extern void checkbound1(long), checkbound2(long, long);
+ extern void call_gen_code(void *, ...);
+ long x, y;
+ x = atoi(argv[1]);
+ if (argc >= 3) {
+ y = atoi(argv[2]);
+ if ((unsigned long) x < (unsigned long) y)
+ printf("Should not trap\n");
+ else
+ printf("Should trap\n");
+ call_gen_code(checkbound2, y, x);
+ } else {
+ if (2 < (unsigned long) x)
+ printf("Should not trap\n");
+ else
+ printf("Should trap\n");
+ call_gen_code(checkbound1, x);
+ }
+ printf("OK\n");
+ }
+#endif
+ return 0;
+}
--- /dev/null
+open Clflags
+let write_asm_file = ref false
+
+let compile_file filename =
+ if !write_asm_file then begin
+ let out_name = Filename.chop_extension filename ^ ".s" in
+ Emitaux.output_channel := open_out out_name
+ end; (* otherwise, stdout *)
+ Compilenv.reset "test";
+ Emit.begin_assembly();
+ let ic = open_in filename in
+ let lb = Lexing.from_channel ic in
+ lb.Lexing.lex_curr_p <- { lb.Lexing.lex_curr_p with pos_fname = filename };
+ try
+ while true do
+ Asmgen.compile_phrase Format.std_formatter
+ (Parsecmm.phrase Lexcmm.token lb)
+ done
+ with
+ End_of_file ->
+ close_in ic; Emit.end_assembly();
+ if !write_asm_file then close_out !Emitaux.output_channel
+ | Lexcmm.Error msg ->
+ close_in ic; Lexcmm.report_error lb msg
+ | Parsing.Parse_error ->
+ close_in ic;
+ let start_p = Lexing.lexeme_start_p lb in
+ let end_p = Lexing.lexeme_end_p lb in
+ Printf.eprintf "File \"%s\", line %i, characters %i-%i:\n\
+ Syntax error.\n%!"
+ filename
+ start_p.Lexing.pos_lnum
+ (start_p.Lexing.pos_cnum - start_p.Lexing.pos_bol)
+ (end_p.Lexing.pos_cnum - start_p.Lexing.pos_bol)
+ | Parsecmmaux.Error msg ->
+ close_in ic; Parsecmmaux.report_error msg
+ | x ->
+ close_in ic; raise x
+
+let usage = "Usage: codegen <options> <files>\noptions are:"
+
+let main() =
+ Arg.parse [
+ "-S", Arg.Set write_asm_file,
+ " Output file to filename.s (default is stdout)";
+ "-g", Arg.Set Clflags.debug, "";
+ "-dcmm", Arg.Set dump_cmm, "";
+ "-dcse", Arg.Set dump_cse, "";
+ "-dsel", Arg.Set dump_selection, "";
+ "-dlive", Arg.Unit(fun () -> dump_live := true;
+ Printmach.print_live := true), "";
+ "-dspill", Arg.Set dump_spill, "";
+ "-dsplit", Arg.Set dump_split, "";
+ "-dinterf", Arg.Set dump_interf, "";
+ "-dprefer", Arg.Set dump_prefer, "";
+ "-dalloc", Arg.Set dump_regalloc, "";
+ "-dreload", Arg.Set dump_reload, "";
+ "-dscheduling", Arg.Set dump_scheduling, "";
+ "-dlinear", Arg.Set dump_linear, "";
+ "-dtimings", Arg.Unit (fun () -> profile_columns := [ `Time ]), "";
+ ] compile_file usage
+
+let () =
+ main ();
+ Profile.print Format.std_formatter !Clflags.profile_columns;
+ exit 0
--- /dev/null
+/**************************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 1996 Institut National de Recherche en Informatique et */
+/* en Automatique. */
+/* */
+/* All rights reserved. This file is distributed under the terms of */
+/* the GNU Lesser General Public License version 2.1, with the */
+/* special exception on linking described in the file LICENSE. */
+/* */
+/**************************************************************************/
+
+#include <stdio.h>
+#include <math.h>
+#include <time.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "../../../byterun/caml/config.h"
+#define FMT ARCH_INTNAT_PRINTF_FORMAT
+
+void caml_ml_array_bound_error(void)
+{
+ fprintf(stderr, "Fatal error: out-of-bound access in array or string\n");
+ exit(2);
+}
+
+intnat R[200];
+double D[40];
+intnat X, Y;
+double F, G;
+
+#define INTTEST(arg,res) \
+ { intnat result = (res); \
+ if (arg != result) \
+ printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: " \
+ "result %"FMT"d, expected %"FMT"d\n", \
+ #arg, #res, X, Y, arg, result); \
+ }
+#define INTFLOATTEST(arg,res) \
+ { intnat result = (res); \
+ if (arg != result) \
+ printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: "\
+ "result %"FMT"d, expected %"FMT"d\n", \
+ #arg, #res, F, G, arg, result); \
+ }
+#define FLOATTEST(arg,res) \
+ { double result = (res); \
+ if (arg < result || arg > result) \
+ printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: "\
+ "result %.15g, expected %.15g\n", \
+ #arg, #res, F, G, arg, result); \
+ }
+#define FLOATINTTEST(arg,res) \
+ { double result = (res); \
+ if (arg < result || arg > result) \
+ printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: "\
+ "result %.15g, expected %.15g\n", \
+ #arg, #res, X, Y, arg, result); \
+ }
+
+extern void call_gen_code(void (*)(void));
+extern void testarith(void);
+static intnat mulhs(intnat x, intnat y);
+
+void do_test(void)
+{
+ call_gen_code(testarith);
+
+ INTTEST(R[0], 0);
+ INTTEST(R[1], 1);
+ INTTEST(R[2], -1);
+ INTTEST(R[3], 256);
+ INTTEST(R[4], 65536);
+ INTTEST(R[5], 16777216);
+ INTTEST(R[6], -256);
+ INTTEST(R[7], -65536);
+ INTTEST(R[8], -16777216);
+
+ INTTEST(R[9], (X + Y));
+ INTTEST(R[10], (X + 1));
+ INTTEST(R[11], (X + -1));
+
+ INTTEST(R[12], ((intnat) ((char *)R + 8)));
+ INTTEST(R[13], ((intnat) ((char *)R + Y)));
+
+ INTTEST(R[14], (X - Y));
+ INTTEST(R[15], (X - 1));
+ INTTEST(R[16], (X - -1));
+
+ INTTEST(R[17], ((intnat) ((uintnat)R - 8)));
+ INTTEST(R[18], ((intnat) ((char *)R - Y)));
+
+ INTTEST(R[19], (X * 2));
+ INTTEST(R[20], (2 * X));
+ INTTEST(R[21], (X * 16));
+ INTTEST(R[22], (16 * X));
+ INTTEST(R[23], (X * 12345));
+ INTTEST(R[24], (12345 * X));
+ INTTEST(R[25], (X * Y));
+
+ INTTEST(R[26], (X / 2));
+ INTTEST(R[27], (X / 16));
+ INTTEST(R[28], (X / 7));
+ INTTEST(R[29], (Y != 0 ? X / Y : 0));
+
+ INTTEST(R[30], (X % 2));
+ INTTEST(R[31], (X % 16));
+ INTTEST(R[32], (Y != 0 ? X % Y : 0));
+
+ INTTEST(R[33], (X & Y));
+ INTTEST(R[34], (X & 3));
+ INTTEST(R[35], (3 & X));
+
+ INTTEST(R[36], (X | Y));
+ INTTEST(R[37], (X | 3));
+ INTTEST(R[38], (3 | X));
+
+ INTTEST(R[39], (X ^ Y));
+ INTTEST(R[40], (X ^ 3));
+ INTTEST(R[41], (3 ^ X));
+
+ INTTEST(R[42], (X << Y));
+ INTTEST(R[43], (X << 1));
+ INTTEST(R[44], (X << 8));
+
+ INTTEST(R[45], ((uintnat) X >> Y));
+ INTTEST(R[46], ((uintnat) X >> 1));
+ INTTEST(R[47], ((uintnat) X >> 8));
+
+ INTTEST(R[48], (X >> Y));
+ INTTEST(R[49], (X >> 1));
+ INTTEST(R[50], (X >> 8));
+
+ INTTEST(R[51], (X == Y));
+ INTTEST(R[52], (X != Y));
+ INTTEST(R[53], (X < Y));
+ INTTEST(R[54], (X > Y));
+ INTTEST(R[55], (X <= Y));
+ INTTEST(R[56], (X >= Y));
+ INTTEST(R[57], (X == 1));
+ INTTEST(R[58], (X != 1));
+ INTTEST(R[59], (X < 1));
+ INTTEST(R[60], (X > 1));
+ INTTEST(R[61], (X <= 1));
+ INTTEST(R[62], (X >= 1));
+
+ INTTEST(R[63], ((char *)X == (char *)Y));
+ INTTEST(R[64], ((char *)X != (char *)Y));
+ INTTEST(R[65], ((char *)X < (char *)Y));
+ INTTEST(R[66], ((char *)X > (char *)Y));
+ INTTEST(R[67], ((char *)X <= (char *)Y));
+ INTTEST(R[68], ((char *)X >= (char *)Y));
+ INTTEST(R[69], ((char *)X == (char *)1));
+ INTTEST(R[70], ((char *)X != (char *)1));
+ INTTEST(R[71], ((char *)X < (char *)1));
+ INTTEST(R[72], ((char *)X > (char *)1));
+ INTTEST(R[73], ((char *)X <= (char *)1));
+ INTTEST(R[74], ((char *)X >= (char *)1));
+
+ INTTEST(R[75], (X + (Y << 1)));
+ INTTEST(R[76], (X + (Y << 2)));
+ INTTEST(R[77], (X + (Y << 3)));
+ INTTEST(R[78], (X - (Y << 1)));
+ INTTEST(R[79], (X - (Y << 2)));
+ INTTEST(R[80], (X - (Y << 3)));
+
+ FLOATTEST(D[0], 0.0);
+ FLOATTEST(D[1], 1.0);
+ FLOATTEST(D[2], -1.0);
+ FLOATTEST(D[3], (F + G));
+ FLOATTEST(D[4], (F - G));
+ FLOATTEST(D[5], (F * G));
+ FLOATTEST(D[6], F / G);
+
+ FLOATTEST(D[7], (F + (G + 1.0)));
+ FLOATTEST(D[8], (F - (G + 1.0)));
+ FLOATTEST(D[9], (F * (G + 1.0)));
+ FLOATTEST(D[10], F / (G + 1.0));
+
+ FLOATTEST(D[11], ((F + 1.0) + G));
+ FLOATTEST(D[12], ((F + 1.0) - G));
+ FLOATTEST(D[13], ((F + 1.0) * G));
+ FLOATTEST(D[14], (F + 1.0) / G);
+
+ FLOATTEST(D[15], ((F + 1.0) + (G + 1.0)));
+ FLOATTEST(D[16], ((F + 1.0) - (G + 1.0)));
+ FLOATTEST(D[17], ((F + 1.0) * (G + 1.0)));
+ FLOATTEST(D[18], (F + 1.0) / (G + 1.0));
+
+ INTFLOATTEST(R[81], (F == G));
+ INTFLOATTEST(R[82], (F != G));
+ INTFLOATTEST(R[83], (F < G));
+ INTFLOATTEST(R[84], (F > G));
+ INTFLOATTEST(R[85], (F <= G));
+ INTFLOATTEST(R[86], (F >= G));
+
+ FLOATINTTEST(D[19], (double) X);
+ INTFLOATTEST(R[87], (intnat) F);
+
+ INTTEST(R[88], (X >= 0) && (X < Y));
+ INTTEST(R[89], (0 < Y));
+ INTTEST(R[90], (5 < Y));
+
+ INTFLOATTEST(R[91], (F == G));
+ INTFLOATTEST(R[92], (F != G));
+ INTFLOATTEST(R[93], (F < G));
+ INTFLOATTEST(R[94], (F > G));
+ INTFLOATTEST(R[95], (F <= G));
+ INTFLOATTEST(R[96], (F >= G));
+
+ INTFLOATTEST(R[97], (F + 1.0 == G + 1.0));
+ INTFLOATTEST(R[98], (F + 1.0 != G + 1.0));
+ INTFLOATTEST(R[99], (F + 1.0 < G + 1.0));
+ INTFLOATTEST(R[100], (F + 1.0 > G + 1.0));
+ INTFLOATTEST(R[101], (F + 1.0 <= G + 1.0));
+ INTFLOATTEST(R[102], (F + 1.0 >= G + 1.0));
+
+ INTFLOATTEST(R[103], (F == G + 1.0));
+ INTFLOATTEST(R[104], (F != G + 1.0));
+ INTFLOATTEST(R[105], (F < G + 1.0));
+ INTFLOATTEST(R[106], (F > G + 1.0));
+ INTFLOATTEST(R[107], (F <= G + 1.0));
+ INTFLOATTEST(R[108], (F >= G + 1.0));
+
+ INTFLOATTEST(R[109], (F + 1.0 == G));
+ INTFLOATTEST(R[110], (F + 1.0 != G));
+ INTFLOATTEST(R[111], (F + 1.0 < G));
+ INTFLOATTEST(R[112], (F + 1.0 > G));
+ INTFLOATTEST(R[113], (F + 1.0 <= G));
+ INTFLOATTEST(R[114], (F + 1.0 >= G));
+
+ FLOATINTTEST(D[20], ((double) X) + 1.0);
+ INTFLOATTEST(R[115], (intnat)(F + 1.0));
+
+ FLOATTEST(D[21], F + G);
+ FLOATTEST(D[22], G + F);
+ FLOATTEST(D[23], F - G);
+ FLOATTEST(D[24], G - F);
+ FLOATTEST(D[25], F * G);
+ FLOATTEST(D[26], G * F);
+ FLOATTEST(D[27], F / G);
+ FLOATTEST(D[28], G / F);
+
+ FLOATTEST(D[29], (F * 2.0) + G);
+ FLOATTEST(D[30], G + (F * 2.0));
+ FLOATTEST(D[31], (F * 2.0) - G);
+ FLOATTEST(D[32], G - (F * 2.0));
+ FLOATTEST(D[33], (F + 2.0) * G);
+ FLOATTEST(D[34], G * (F + 2.0));
+ FLOATTEST(D[35], (F * 2.0) / G);
+ FLOATTEST(D[36], G / (F * 2.0));
+
+ FLOATTEST(D[37], - F);
+ FLOATTEST(D[38], fabs(F));
+
+ INTTEST(R[116], mulhs(X, Y));
+}
+
+/* Multiply-high signed. Hacker's Delight section 8.2 */
+
+#define HALFSIZE (4 * sizeof(intnat))
+#define HALFMASK (((intnat)1 << HALFSIZE) - 1)
+
+static intnat mulhs(intnat u, intnat v)
+{
+ uintnat u0, v0, w0;
+ intnat u1, v1, w1, w2, t;
+ u0 = u & HALFMASK; u1 = u >> HALFSIZE;
+ v0 = v & HALFMASK; v1 = v >> HALFSIZE;
+ w0 = u0*v0;
+ t = u1*v0 + (w0 >> HALFSIZE);
+ w1 = t & HALFMASK;
+ w2 = t >> HALFSIZE;
+ w1 = u0*v1 + w1;
+ return u1*v1 + w2 + (w1 >> HALFSIZE);
+}
+
+/* A simple linear congruential PRNG */
+
+#ifdef ARCH_SIXTYFOUR
+#define RAND_A 6364136223846793005ULL
+#define RAND_C 1442695040888963407ULL
+#else
+#define RAND_A 214013U
+#define RAND_C 2531011U
+#endif
+
+static intnat rnd(void)
+{
+ static uintnat seed = 0;
+ seed = seed * RAND_A + RAND_C;
+ return (intnat) seed;
+}
+
+/* Test harness */
+
+#define NUM_RANDOM_ITERATIONS 1000000
+
+int main(int argc, char **argv)
+{
+ int i;
+ double weird[4];
+
+ if (argc >= 5) {
+ X = atoi(argv[1]);
+ Y = atoi(argv[2]);
+ sscanf(argv[3], "%lf", &F);
+ sscanf(argv[4], "%lf", &G);
+ do_test();
+ return 0;
+ }
+ printf("Testing -2...2\n");
+ for(Y = -2; Y <= 2; Y++) {
+ for (X = -2; X <= 2; X++) {
+ F = X; G = Y; do_test();
+ }
+ }
+ if (!(argc >= 2 && strcmp(argv[1], "noinf"))) {
+ printf("Testing special FP values\n");
+ weird[0] = 0.0;
+ weird[1] = 1.0 / weird[0]; /* +infty */
+ weird[2] = -1.0 / weird[0]; /* -infty */
+ weird[3] = 0.0 / weird[0]; /* NaN */
+ for (X = 0; X < 4; X++) {
+ for (Y = 0; Y < 4; Y++) {
+ F = weird[X]; G = weird[Y]; do_test();
+ }
+ }
+ }
+ printf("Testing %d random values\n", NUM_RANDOM_ITERATIONS);
+ for (i = 0; i < NUM_RANDOM_ITERATIONS; i++) {
+ X = rnd();
+ Y = rnd();
+ F = X / 1e3;
+ G = Y / 1e3;
+ do_test();
+ }
+ return 0;
+}
--- /dev/null
+/* A simple parser for C-- */
+
+%{
+open Cmm
+open Parsecmmaux
+
+let rec make_letdef def body =
+ match def with
+ [] -> body
+ | (id, def) :: rem ->
+ unbind_ident id;
+ Clet(id, def, make_letdef rem body)
+
+let make_switch n selector caselist =
+ let index = Array.make n 0 in
+ let casev = Array.of_list caselist in
+ let actv = Array.make (Array.length casev) (Cexit(0,[])) in
+ for i = 0 to Array.length casev - 1 do
+ let (posl, e) = casev.(i) in
+ List.iter (fun pos -> index.(pos) <- i) posl;
+ actv.(i) <- e
+ done;
+ Cswitch(selector, index, actv, Debuginfo.none)
+
+let access_array base numelt size =
+ match numelt with
+ Cconst_int 0 -> base
+ | Cconst_int n -> Cop(Cadda, [base; Cconst_int(n * size)], Debuginfo.none)
+ | _ -> Cop(Cadda, [base;
+ Cop(Clsl, [numelt; Cconst_int(Misc.log2 size)],
+ Debuginfo.none)],
+ Debuginfo.none)
+
+%}
+
+%token ABSF
+%token ADDA
+%token ADDF
+%token ADDI
+%token ADDV
+%token ADDR
+%token ALIGN
+%token ALLOC
+%token AND
+%token APPLY
+%token ASR
+%token ASSIGN
+%token BYTE
+%token CASE
+%token CATCH
+%token CHECKBOUND
+%token COLON
+%token DATA
+%token DIVF
+%token DIVI
+%token EOF
+%token EQA
+%token EQF
+%token EQI
+%token EXIT
+%token EXTCALL
+%token FLOAT
+%token FLOAT32
+%token FLOAT64
+%token <string> FLOATCONST
+%token FLOATOFINT
+%token FUNCTION
+%token GEA
+%token GEF
+%token GEI
+%token GLOBAL
+%token GTA
+%token GTF
+%token GTI
+%token HALF
+%token <string> IDENT
+%token IF
+%token INT
+%token INT32
+%token <int> INTCONST
+%token INTOFFLOAT
+%token KSTRING
+%token LBRACKET
+%token LEA
+%token LEF
+%token LEI
+%token LET
+%token LOAD
+%token <Location.t> LOCATION
+%token LPAREN
+%token LSL
+%token LSR
+%token LTA
+%token LTF
+%token LTI
+%token MODI
+%token MULF
+%token MULH
+%token MULI
+%token NEA
+%token NEF
+%token NEI
+%token NGEF
+%token NGTF
+%token NLEF
+%token NLTF
+%token OR
+%token <int> POINTER
+%token PROJ
+%token <Cmm.raise_kind> RAISE
+%token RBRACKET
+%token RPAREN
+%token SEQ
+%token SIGNED
+%token SKIP
+%token STAR
+%token STORE
+%token <string> STRING
+%token SUBF
+%token SUBI
+%token SWITCH
+%token TRY
+%token UNIT
+%token UNSIGNED
+%token VAL
+%token WHILE
+%token WITH
+%token XOR
+%token ADDRAREF
+%token INTAREF
+%token FLOATAREF
+%token ADDRASET
+%token INTASET
+%token FLOATASET
+
+%start phrase
+%type <Cmm.phrase> phrase
+
+%%
+
+phrase:
+ fundecl { Cfunction $1 }
+ | datadecl { Cdata $1 }
+ | EOF { raise End_of_file }
+;
+fundecl:
+ LPAREN FUNCTION fun_name LPAREN params RPAREN sequence RPAREN
+ { List.iter (fun (id, ty) -> unbind_ident id) $5;
+ {fun_name = $3; fun_args = $5; fun_body = $7;
+ fun_codegen_options =
+ if Config.flambda then [
+ Reduce_code_size;
+ No_CSE;
+ ]
+ else [ Reduce_code_size ];
+ fun_dbg = debuginfo ()} }
+;
+fun_name:
+ STRING { $1 }
+ | IDENT { $1 }
+params:
+ oneparam params { $1 :: $2 }
+ | /**/ { [] }
+;
+oneparam:
+ IDENT COLON machtype { (bind_ident $1, $3) }
+;
+machtype:
+ UNIT { [||] }
+ | componentlist { Array.of_list(List.rev $1) }
+;
+component:
+ VAL { Val }
+ | ADDR { Addr }
+ | INT { Int }
+ | FLOAT { Float }
+;
+componentlist:
+ component { [$1] }
+ | componentlist STAR component { $3 :: $1 }
+;
+expr:
+ INTCONST { Cconst_int $1 }
+ | FLOATCONST { Cconst_float (float_of_string $1) }
+ | STRING { Cconst_symbol $1 }
+ | POINTER { Cconst_pointer $1 }
+ | IDENT { Cvar(find_ident $1) }
+ | LBRACKET RBRACKET { Ctuple [] }
+ | LPAREN LET letdef sequence RPAREN { make_letdef $3 $4 }
+ | LPAREN ASSIGN IDENT expr RPAREN { Cassign(find_ident $3, $4) }
+ | LPAREN APPLY location expr exprlist machtype RPAREN
+ { Cop(Capply $6, $4 :: List.rev $5, debuginfo ?loc:$3 ()) }
+ | LPAREN EXTCALL STRING exprlist machtype RPAREN
+ {Cop(Cextcall($3, $5, false, None), List.rev $4, debuginfo ())}
+ | LPAREN ALLOC exprlist RPAREN { Cop(Calloc, List.rev $3, debuginfo ()) }
+ | LPAREN SUBF expr RPAREN { Cop(Cnegf, [$3], debuginfo ()) }
+ | LPAREN SUBF expr expr RPAREN { Cop(Csubf, [$3; $4], debuginfo ()) }
+ | LPAREN unaryop expr RPAREN { Cop($2, [$3], debuginfo ()) }
+ | LPAREN binaryop expr expr RPAREN { Cop($2, [$3; $4], debuginfo ()) }
+ | LPAREN SEQ sequence RPAREN { $3 }
+ | LPAREN IF expr expr expr RPAREN { Cifthenelse($3, $4, $5) }
+ | LPAREN SWITCH INTCONST expr caselist RPAREN { make_switch $3 $4 $5 }
+ | LPAREN WHILE expr sequence RPAREN
+ { let body =
+ match $3 with
+ Cconst_int x when x <> 0 -> $4
+ | _ -> Cifthenelse($3, $4, (Cexit(0,[]))) in
+ Ccatch(Recursive, [0, [], Cloop body], Ctuple []) }
+ | LPAREN EXIT IDENT exprlist RPAREN
+ { Cexit(find_label $3, List.rev $4) }
+ | LPAREN CATCH sequence WITH catch_handlers RPAREN
+ { let handlers = $5 in
+ List.iter (fun (_, l, _) -> List.iter unbind_ident l) handlers;
+ Ccatch(Recursive, handlers, $3) }
+ | EXIT { Cexit(0,[]) }
+ | LPAREN TRY sequence WITH bind_ident sequence RPAREN
+ { unbind_ident $5; Ctrywith($3, $5, $6) }
+ | LPAREN VAL expr expr RPAREN
+ { Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr],
+ debuginfo ()) }
+ | LPAREN ADDRAREF expr expr RPAREN
+ { Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr],
+ Debuginfo.none) }
+ | LPAREN INTAREF expr expr RPAREN
+ { Cop(Cload (Word_int, Mutable), [access_array $3 $4 Arch.size_int],
+ Debuginfo.none) }
+ | LPAREN FLOATAREF expr expr RPAREN
+ { Cop(Cload (Double_u, Mutable), [access_array $3 $4 Arch.size_float],
+ Debuginfo.none) }
+ | LPAREN ADDRASET expr expr expr RPAREN
+ { Cop(Cstore (Word_val, Assignment),
+ [access_array $3 $4 Arch.size_addr; $5], Debuginfo.none) }
+ | LPAREN INTASET expr expr expr RPAREN
+ { Cop(Cstore (Word_int, Assignment),
+ [access_array $3 $4 Arch.size_int; $5], Debuginfo.none) }
+ | LPAREN FLOATASET expr expr expr RPAREN
+ { Cop(Cstore (Double_u, Assignment),
+ [access_array $3 $4 Arch.size_float; $5], Debuginfo.none) }
+;
+exprlist:
+ exprlist expr { $2 :: $1 }
+ | /**/ { [] }
+;
+letdef:
+ oneletdef { [$1] }
+ | LPAREN letdefmult RPAREN { $2 }
+;
+letdefmult:
+ /**/ { [] }
+ | oneletdef letdefmult { $1 :: $2 }
+;
+oneletdef:
+ IDENT expr { (bind_ident $1, $2) }
+;
+chunk:
+ UNSIGNED BYTE { Byte_unsigned }
+ | SIGNED BYTE { Byte_signed }
+ | UNSIGNED HALF { Sixteen_unsigned }
+ | SIGNED HALF { Sixteen_signed }
+ | UNSIGNED INT32 { Thirtytwo_unsigned }
+ | SIGNED INT32 { Thirtytwo_signed }
+ | INT { Word_int }
+ | ADDR { Word_val }
+ | FLOAT32 { Single }
+ | FLOAT64 { Double }
+ | FLOAT { Double_u }
+ | VAL { Word_val }
+;
+unaryop:
+ LOAD chunk { Cload ($2, Mutable) }
+ | FLOATOFINT { Cfloatofint }
+ | INTOFFLOAT { Cintoffloat }
+ | RAISE { Craise $1 }
+ | ABSF { Cabsf }
+;
+binaryop:
+ STORE chunk { Cstore ($2, Assignment) }
+ | ADDI { Caddi }
+ | SUBI { Csubi }
+ | STAR { Cmuli }
+ | DIVI { Cdivi }
+ | MODI { Cmodi }
+ | AND { Cand }
+ | OR { Cor }
+ | XOR { Cxor }
+ | LSL { Clsl }
+ | LSR { Clsr }
+ | ASR { Casr }
+ | EQI { Ccmpi Ceq }
+ | NEI { Ccmpi Cne }
+ | LTI { Ccmpi Clt }
+ | LEI { Ccmpi Cle }
+ | GTI { Ccmpi Cgt }
+ | GEI { Ccmpi Cge }
+ | ADDA { Cadda }
+ | ADDV { Caddv }
+ | EQA { Ccmpa Ceq }
+ | NEA { Ccmpa Cne }
+ | LTA { Ccmpa Clt }
+ | LEA { Ccmpa Cle }
+ | GTA { Ccmpa Cgt }
+ | GEA { Ccmpa Cge }
+ | ADDF { Caddf }
+ | MULF { Cmulf }
+ | DIVF { Cdivf }
+ | EQF { Ccmpf CFeq }
+ | NEF { Ccmpf CFneq }
+ | LTF { Ccmpf CFlt }
+ | NLTF { Ccmpf CFnlt }
+ | LEF { Ccmpf CFle }
+ | NLEF { Ccmpf CFnle }
+ | GTF { Ccmpf CFgt }
+ | NGTF { Ccmpf CFngt }
+ | GEF { Ccmpf CFge }
+ | NGEF { Ccmpf CFnge }
+ | CHECKBOUND { Ccheckbound }
+ | MULH { Cmulhi }
+;
+sequence:
+ expr sequence { Csequence($1, $2) }
+ | expr { $1 }
+;
+caselist:
+ onecase sequence caselist { ($1, $2) :: $3 }
+ | /**/ { [] }
+;
+onecase:
+ CASE INTCONST COLON onecase { $2 :: $4 }
+ | CASE INTCONST COLON { [$2] }
+;
+bind_ident:
+ IDENT { bind_ident $1 }
+;
+datadecl:
+ LPAREN datalist RPAREN { List.rev $2 }
+ | LPAREN DATA datalist RPAREN { List.rev $3 }
+;
+datalist:
+ datalist dataitem { $2 :: $1 }
+ | /**/ { [] }
+;
+dataitem:
+ STRING COLON { Cdefine_symbol $1 }
+ | BYTE INTCONST { Cint8 $2 }
+ | HALF INTCONST { Cint16 $2 }
+ | INT INTCONST { Cint(Nativeint.of_int $2) }
+ | FLOAT FLOATCONST { Cdouble (float_of_string $2) }
+ | ADDR STRING { Csymbol_address $2 }
+ | VAL STRING { Csymbol_address $2 }
+ | KSTRING STRING { Cstring $2 }
+ | SKIP INTCONST { Cskip $2 }
+ | ALIGN INTCONST { Calign $2 }
+ | GLOBAL STRING { Cglobal_symbol $2 }
+;
+catch_handlers:
+ | catch_handler
+ { [$1] }
+ | catch_handler AND catch_handlers
+ { $1 :: $3 }
+
+catch_handler:
+ | sequence
+ { 0, [], $1 }
+ | LPAREN IDENT bind_identlist RPAREN sequence
+ { find_label $2, $3, $5 }
+
+bind_identlist:
+ /**/ { [] }
+ | bind_ident bind_identlist { $1 :: $2 }
+
+location:
+ /**/ { None }
+ | LOCATION { Some $1 }
--- /dev/null
+(* Auxiliary functions for parsing *)
+
+type error =
+ Unbound of string
+
+exception Error of error
+
+let tbl_ident = (Hashtbl.create 57 : (string, Ident.t) Hashtbl.t)
+let tbl_label = (Hashtbl.create 57 : (string, int) Hashtbl.t)
+
+let ident_name s =
+ match String.index s '/' with
+ | exception Not_found -> s
+ | n -> String.sub s 0 n
+
+let bind_ident s =
+ let id = Ident.create (ident_name s) in
+ Hashtbl.add tbl_ident s id;
+ id
+
+let find_ident s =
+ try
+ Hashtbl.find tbl_ident s
+ with Not_found ->
+ raise(Error(Unbound s))
+
+let unbind_ident id =
+ Hashtbl.remove tbl_ident (Ident.name id)
+
+let find_label s =
+ try
+ Hashtbl.find tbl_label s
+ with Not_found ->
+ let lbl = Lambda.next_raise_count () in
+ Hashtbl.add tbl_label s lbl;
+ lbl
+
+let report_error = function
+ Unbound s ->
+ prerr_string "Unbound identifier "; prerr_string s; prerr_endline "."
+
+let debuginfo ?(loc=Location.symbol_rloc ()) () =
+ Debuginfo.(from_location loc)
--- /dev/null
+(* Auxiliary functions for parsing *)
+
+val bind_ident: string -> Ident.t
+val find_ident: string -> Ident.t
+val unbind_ident: Ident.t -> unit
+
+val find_label: string -> int
+
+val debuginfo: ?loc:Location.t -> unit -> Debuginfo.t
+
+type error =
+ Unbound of string
+
+exception Error of error
+
+val report_error: error -> unit
--- /dev/null
+(function "pgcd_30030" (a:int)
+ (catch (exit pgcd a 30030)
+ with (pgcd n m)
+ (if (> n m)
+ (exit pgcd m n)
+ (if (== n 0)
+ m
+ (let (r (mod m n))
+ (exit pgcd r n))))))
\ No newline at end of file
--- /dev/null
+/*********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 1996 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the Q Public License version 1.0. */
+/* */
+/*********************************************************************/
+
+#if defined(MODEL_ppc64) || defined(MODEL_ppc64le)
+#define EITHER(a,b) b
+#else
+#define EITHER(a,b) a
+#endif
+
+#define WORD EITHER(4,8)
+#define lg EITHER(lwz,ld)
+#define lgu EITHER(lwzu,ldu)
+#define stg EITHER(stw,std)
+#define stgu EITHER(stwu,stdu)
+
+#if defined(MODEL_ppc)
+#define RESERVED_STACK 16
+#define LR_SAVE_AREA 4
+#endif
+#if defined(MODEL_ppc64)
+#define RESERVED_STACK 48
+#define LR_SAVE_AREA 16
+#endif
+#if defined(MODEL_ppc64le)
+#define RESERVED_STACK 32
+#define LR_SAVE_AREA 16
+#endif
+
+/* Function definitions */
+
+#if defined(MODEL_ppc)
+#define FUNCTION(name) \
+ .section ".text"; \
+ .globl name; \
+ .type name, @function; \
+ .align 2; \
+ name:
+#endif
+
+#if defined(MODEL_ppc64)
+#define FUNCTION(name) \
+ .section ".opd","aw"; \
+ .align 3; \
+ .globl name; \
+ .type name, @function; \
+ name: .quad .L.name,.TOC.@tocbase; \
+ .text; \
+ .align 2; \
+ .L.name:
+#endif
+
+#if defined(MODEL_ppc64le)
+#define FUNCTION(name) \
+ .section ".text"; \
+ .globl name; \
+ .type name, @function; \
+ .align 2; \
+ name: ; \
+ 0: addis 2, 12, (.TOC. - 0b)@ha; \
+ addi 2, 2, (.TOC. - 0b)@l; \
+ .localentry name, . - 0b
+#endif
+
+FUNCTION(call_gen_code)
+ /* Allocate and link stack frame */
+ stgu 1, -(WORD*18 + 8*18 + RESERVED_STACK)(1)
+ /* 18 saved GPRs, 18 saved FPRs */
+ /* Save return address */
+ mflr 0
+ stg 0, (WORD*18 + 8*18 + RESERVED_STACK + LR_SAVE_AREA)(1)
+ /* Save all callee-save registers, starting at RESERVED_STACK */
+ addi 11, 1, RESERVED_STACK - WORD
+ stgu 14, WORD(11)
+ stgu 15, WORD(11)
+ stgu 16, WORD(11)
+ stgu 17, WORD(11)
+ stgu 18, WORD(11)
+ stgu 19, WORD(11)
+ stgu 20, WORD(11)
+ stgu 21, WORD(11)
+ stgu 22, WORD(11)
+ stgu 23, WORD(11)
+ stgu 24, WORD(11)
+ stgu 25, WORD(11)
+ stgu 26, WORD(11)
+ stgu 27, WORD(11)
+ stgu 28, WORD(11)
+ stgu 29, WORD(11)
+ stgu 30, WORD(11)
+ stgu 31, WORD(11)
+ stfdu 14, 8(11)
+ stfdu 15, 8(11)
+ stfdu 16, 8(11)
+ stfdu 17, 8(11)
+ stfdu 18, 8(11)
+ stfdu 19, 8(11)
+ stfdu 20, 8(11)
+ stfdu 21, 8(11)
+ stfdu 22, 8(11)
+ stfdu 23, 8(11)
+ stfdu 24, 8(11)
+ stfdu 25, 8(11)
+ stfdu 26, 8(11)
+ stfdu 27, 8(11)
+ stfdu 28, 8(11)
+ stfdu 29, 8(11)
+ stfdu 30, 8(11)
+ stfdu 31, 8(11)
+ /* Get function pointer in CTR */
+#if defined(MODEL_ppc)
+ mtctr 3
+#elif defined(MODEL_ppc64)
+ ld 0, 0(3)
+ mtctr 0
+ ld 2, 8(3)
+#elif defined(MODEL_ppc64le)
+ mtctr 3
+ mr 12, 3
+#else
+#error "wrong MODEL"
+#endif
+ /* Shuffle arguments */
+ mr 3, 4
+ mr 4, 5
+ mr 5, 6
+ mr 6, 7
+ /* Call the function */
+ bctrl
+ /* Restore callee-save registers */
+ addi 11, 1, RESERVED_STACK - WORD
+ lgu 14, WORD(11)
+ lgu 15, WORD(11)
+ lgu 16, WORD(11)
+ lgu 17, WORD(11)
+ lgu 18, WORD(11)
+ lgu 19, WORD(11)
+ lgu 20, WORD(11)
+ lgu 21, WORD(11)
+ lgu 22, WORD(11)
+ lgu 23, WORD(11)
+ lgu 24, WORD(11)
+ lgu 25, WORD(11)
+ lgu 26, WORD(11)
+ lgu 27, WORD(11)
+ lgu 28, WORD(11)
+ lgu 29, WORD(11)
+ lgu 30, WORD(11)
+ lgu 31, WORD(11)
+ lfdu 14, 8(11)
+ lfdu 15, 8(11)
+ lfdu 16, 8(11)
+ lfdu 17, 8(11)
+ lfdu 18, 8(11)
+ lfdu 19, 8(11)
+ lfdu 20, 8(11)
+ lfdu 21, 8(11)
+ lfdu 22, 8(11)
+ lfdu 23, 8(11)
+ lfdu 24, 8(11)
+ lfdu 25, 8(11)
+ lfdu 26, 8(11)
+ lfdu 27, 8(11)
+ lfdu 28, 8(11)
+ lfdu 29, 8(11)
+ lfdu 30, 8(11)
+ lfdu 31, 8(11)
+ /* Reload return address */
+ lg 0, (WORD*18 + 8*18 + RESERVED_STACK + LR_SAVE_AREA)(1)
+ mtlr 0
+ /* Return */
+ addi 1, 1, (WORD*18 + 8*18 + RESERVED_STACK)
+ blr
+
+FUNCTION(caml_c_call)
+ /* Jump to C function (address in r28) */
+#if defined(MODEL_ppc)
+ mtctr 28
+#elif defined(MODEL_ppc64)
+ ld 0, 0(28)
+ mtctr 0
+ ld 2, 8(28)
+#elif defined(MODEL_ppc64le)
+ mtctr 28
+ mr 12, 28
+#else
+#error "wrong MODEL"
+#endif
+ bctr
+
+/* Mark stack as non-executable */
+ .section .note.GNU-stack,"",%progbits
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(function "quicksort" (lo: int hi: int a: val)
+ (if (< lo hi)
+ (let (i lo
+ j hi
+ pivot (addraref a hi))
+ (while (< i j)
+ (catch
+ (while 1
+ (if (>= i hi) exit [])
+ (if (> (addraref a i) pivot) exit [])
+ (assign i (+ i 1)))
+ with [])
+ (catch
+ (while 1
+ (if (<= j lo) exit [])
+ (if (< (addraref a j) pivot) exit [])
+ (assign j (- j 1)))
+ with [])
+ (if (< i j)
+ (let temp (addraref a i)
+ (addraset a i (addraref a j))
+ (addraset a j temp))
+ []))
+ (let temp (addraref a i)
+ (addraset a i (addraref a hi))
+ (addraset a hi temp))
+ (app "quicksort" lo (- i 1) a unit)
+ (app "quicksort" (+ i 1) hi a unit))
+ []))
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(function "cmp" (i: int j: int)
+ (- i j))
+
+(function "quick" (lo: int hi: int a: val cmp: val)
+ (if (< lo hi)
+ (let (i lo
+ j hi
+ pivot (intaref a hi))
+ (while (< i j)
+ (catch
+ (while 1
+ (if (>= i hi) exit [])
+ (if (> (app cmp (intaref a i) pivot int) 0) exit [])
+ (assign i (+ i 1)))
+ with [])
+ (catch
+ (while 1
+ (if (<= j lo) exit [])
+ (if (< (app cmp (intaref a j) pivot int) 0) exit [])
+ (assign j (- j 1)))
+ with [])
+ (if (< i j)
+ (let temp (intaref a i)
+ (intaset a i (intaref a j))
+ (intaset a j temp))
+ []))
+ (let temp (intaref a i)
+ (intaset a i (intaref a hi))
+ (intaset a hi temp))
+ (app "quick" lo (- i 1) a cmp unit)
+ (app "quick" (+ i 1) hi a cmp unit))
+ []))
+
+(function "quicksort" (lo: int hi: int a: val)
+ (app "quick" lo hi a "cmp" unit))
--- /dev/null
+#define ALIGN 8
+
+#define CALL_GEN_CODE call_gen_code
+#define CAML_C_CALL caml_c_call
+#define CAML_NEGF_MASK caml_negf_mask
+#define CAML_ABSF_MASK caml_absf_mask
+
+ .section ".text"
+
+ .globl CALL_GEN_CODE
+ .type CALL_GEN_CODE, @function
+ .align ALIGN
+CALL_GEN_CODE:
+ /* Stack space */
+ lay %r15, -144(%r15)
+ /* Save registers */
+ stmg %r6,%r14, 0(%r15)
+ std %f8, 72(%r15)
+ std %f9, 80(%r15)
+ std %f10, 88(%r15)
+ std %f11, 96(%r15)
+ std %f12, 104(%r15)
+ std %f13, 112(%r15)
+ std %f14, 120(%r15)
+ std %f15, 128(%r15)
+ /* Shuffle args */
+ lgr %r1, %r2
+ lgr %r2, %r3
+ lgr %r3, %r4
+ lgr %r4, %r5
+ /* Function call */
+ basr %r14, %r1
+ /* Restore registers */
+ lmg %r6,%r14, 0(%r15)
+ ld %f8, 72(%r15)
+ ld %f9, 80(%r15)
+ ld %f10, 88(%r15)
+ ld %f11, 96(%r15)
+ ld %f12, 104(%r15)
+ ld %f13, 112(%r15)
+ ld %f14, 120(%r15)
+ ld %f15, 128(%r15)
+ /* Return */
+ lay %r15, 144(%r15)
+ br %r14
+
+ .globl CAML_C_CALL
+ .type CAML_C_CALL, @function
+ .align ALIGN
+CAML_C_CALL:
+ br %r7
+
+ .section ".rodata"
+
+ .global CAML_NEGF_MASK
+ .align ALIGN
+CAML_NEGF_MASK:
+ .quad 0x8000000000000000, 0
+ .global CAML_ABSF_MASK
+ .align ALIGN
+CAML_ABSF_MASK:
+ .quad 0x7FFFFFFFFFFFFFFF, 0
+
+ .comm young_limit, 8
+
+/* Mark stack as non-executable */
+ .section .note.GNU-stack,"",%progbits
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+("d1": int 0 int 1
+ "d2": int 1 int 0
+ "d3": int 0 int -1
+ "d4": int -1 int 0
+ "dir": val "d1" val "d2" val "d3" val "d4")
+
+("counter": int 0)
+
+(* Out = 0 Empty = 1 Peg = 2 *)
+
+("line0": int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0
+ "line1": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
+ "line2": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
+ "line3": int 0 int 2 int 2 int 2 int 2 int 2 int 2 int 2 int 0
+ "line4": int 0 int 2 int 2 int 2 int 1 int 2 int 2 int 2 int 0
+ "line5": int 0 int 2 int 2 int 2 int 2 int 2 int 2 int 2 int 0
+ "line6": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
+ "line7": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
+ "line8": int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0
+ "board": val "line0" val "line1" val "line2" val "line3"
+ val "line4" val "line5" val "line6" val "line7" val "line8")
+
+("format": string "%d\n\000")
+
+(function "solve" (m: int)
+ (store int "counter" (+ (load int "counter") 1))
+ (if (== m 31)
+ (== (intaref (addraref "board" 4) 4) 2)
+ (try
+ (if (== (mod (load int "counter") 500) 0)
+ (extcall "printf_int" "format" (load int "counter") unit)
+ [])
+ (let i 1
+ (while (<= i 7)
+ (let j 1
+ (while (<= j 7)
+ (if (== (intaref (addraref "board" i) j) 2)
+ (seq
+ (let k 0
+ (while (<= k 3)
+ (let (d1 (intaref (addraref "dir" k) 0)
+ d2 (intaref (addraref "dir" k) 1)
+ i1 (+ i d1)
+ i2 (+ i1 d1)
+ j1 (+ j d2)
+ j2 (+ j1 d2))
+ (if (== (intaref (addraref "board" i1) j1) 2)
+ (if (== (intaref (addraref "board" i2) j2) 1)
+ (seq
+ (intaset (addraref "board" i) j 1)
+ (intaset (addraref "board" i1) j1 1)
+ (intaset (addraref "board" i2) j2 2)
+ (if (app "solve" (+ m 1) int)
+ (raise_notrace 0a)
+ [])
+ (intaset (addraref "board" i) j 2)
+ (intaset (addraref "board" i1) j1 2)
+ (intaset (addraref "board" i2) j2 1))
+ [])
+ []))
+ (assign k (+ k 1)))))
+ [])
+ (assign j (+ j 1))))
+ (assign i (+ i 1))))
+ 0
+ with bucket
+ 1)))
+
+("format_out": string ".\000")
+("format_empty": string " \000")
+("format_peg": string "$\000")
+("format_newline": string "\n\000")
+
+(function "print_board" ()
+ (let i 0
+ (while (< i 9)
+ (let j 0
+ (while (< j 9)
+ (switch 3 (intaref (addraref "board" i) j)
+ case 0:
+ (extcall "print_string" "format_out" unit)
+ case 1:
+ (extcall "print_string" "format_empty" unit)
+ case 2:
+ (extcall "print_string" "format_peg" unit))
+ (assign j (+ j 1))))
+ (extcall "print_string" "format_newline" unit)
+ (assign i (+ i 1)))))
+
+(function "solitaire" ()
+ (seq
+ (if (app "solve" 0 int)
+ (app "print_board" [] unit)
+ [])
+ 0))
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(function "fib" (n: int)
+ (if (< n 5)
+ 3
+ (- (+ (app "fib" (- n 2) int) (app "fib" (- n 4) int)) 1)))
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+("res_square": skip 8)
+("h": skip 8)
+("x": skip 8)
+("s": skip 8)
+("res_integr": skip 8)
+
+(function "square" (x: val)
+ (let r "res_square"
+ (store float r ( *f (load float x) (load float x)))
+ r))
+
+(function "integr" (f: val low: val high: val n: int)
+ (let (h "h" x "x" s "s" i n)
+ (store float h (/f (-f (load float high) (load float low)) (floatofint n)))
+ (store float x (load float low))
+ (store float s 0.0)
+ (while (> i 0)
+ (store float s (+f (load float s) (load float (app f x val))))
+ (store float x (+f (load float x) (load float h)))
+ (assign i (- i 1)))
+ (store float "res_integr" ( *f (load float s) (load float h)))
+ "res_integr"))
+
+("low": skip 8)
+("hi": skip 8)
+
+(function "test" (n: int)
+ (store float "low" 0.0)
+ (store float "hi" 1.0)
+ (load float (app "integr" "square" "low" "hi" n val)))
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(function "quick" (lo: int hi: int a: val)
+ (if (< lo hi)
+ (let (i lo
+ j hi
+ pivot (addraref a (>>s hi 1)))
+ (while (< i j)
+ (catch
+ (while 1
+ (if (>= i hi) exit [])
+ (if (> (addraref a (>>s i 1)) pivot) exit [])
+ (assign i (+ i 2)))
+ with [])
+ (catch
+ (while 1
+ (if (<= j lo) exit [])
+ (if (< (addraref a (>>s j 1)) pivot) exit [])
+ (assign j (- j 2)))
+ with [])
+ (if (< i j)
+ (let temp (addraref a (>>s i 1))
+ (addraset a (>>s i 1) (addraref a (>>s j 1)))
+ (addraset a (>>s j 1) temp))
+ []))
+ (let temp (addraref a (>>s i 1))
+ (addraset a (>>s i 1) (addraref a (>>s hi 1)))
+ (addraset a (>>s hi 1) temp))
+ (app "quick" lo (- i 2) a unit)
+ (app "quick" (+ i 2) hi a unit))
+ []))
+
+(function "quicksort" (lo: int hi: int a: val)
+ (app "quick" (+ (<< lo 1) 1) (+ (<< hi 1) 1) a unit))
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(function "tak" (x:int y:int z:int)
+ (if (> x y)
+ (app "tak" (app "tak" (- x 2) y z int)
+ (app "tak" (- y 2) z x int)
+ (app "tak" (- z 2) x y int) int)
+ z))
+
+(function "takmain" (dummy: int)
+ (app "tak" 37 25 13 int))
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(function "tak" (x:int y:int z:int)
+ (if (> x y)
+ (app "tak" (app "tak" (- x 1) y z int)
+ (app "tak" (- y 1) z x int)
+ (app "tak" (- z 1) x y int) int)
+ z))
+
+(function "takmain" (dummy: int)
+ (app "tak" 18 12 6 int))
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Jeremie Dimino, Jane Street Europe #
-# #
-# Copyright 2015 Jane Street Group LLC #
-# #
-# All rights reserved. This file is distributed under the terms of #
-# the GNU Lesser General Public License version 2.1, with the #
-# special exception on linking described in the file ../LICENSE. #
-# #
-#########################################################################
-
-BASEDIR=../..
-COMPFLAGS=-I $(OTOPDIR)/parsing -I $(OTOPDIR)/utils \
- -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-LIBRARIES=../../../compilerlibs/ocamlcommon unix
-MODULES=
-MAIN_MODULE=test
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
-
-# This test is a bit slow and there is little value in testing both
-# versions so we run only the native code one:
-NATIVECODE_ONLY=true
+(* TEST
+ include ocamlcommon
+ include unix
+ arguments = "${ocamlsrcdir}"
+ * native
+*)
+
(* This test checks all ml files in the ocaml repository that are accepted
by the parser satisfy [Ast_invariants].
is to ensure that the parser doesn't accept more than [Ast_invariants].
*)
-let root = "../../.."
+let root = Sys.argv.(1)
+
let () = assert (Sys.file_exists (Filename.concat root "VERSION"))
type _ kind =
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-EXECNAME=program$(EXE)
-
-ABCDFILES=backtrace.ml
-OTHERFILES=backtrace2.ml backtrace3.ml raw_backtrace.ml \
- backtrace_deprecated.ml backtrace_slots.ml
-INLININGFILES=inline_test.ml inline_traversal_test.ml
-OTHERFILESNOINLINING=pr6920_why_at.ml pr6920_why_swallow.ml
-OTHERFILESNOINLINING_NATIVE=backtraces_and_finalizers.ml
-
-# Keep only filenames, lines and character ranges
-LOCATIONFILTER=grep -oE \
- '[a-zA-Z_]+\.ml(:[0-9]+)?|(line|characters) [0-9-]+'
-
-default:
- @$(MAKE) byte
- @if $(BYTECODE_ONLY); then $(MAKE) skip ; else $(MAKE) native; fi
-
-.PHONY: byte
-byte:
- @for file in $(ABCDFILES); do \
- rm -f program program.exe; \
- $(OCAMLC) -g -o $(EXECNAME) $$file; \
- for arg in a b c d ''; do \
- printf " ... testing '$$file' with ocamlc and argument '$$arg':"; \
- F="`basename $$file .ml`"; \
- (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
- $(OCAMLRUN) $(EXECNAME) $$arg || true) \
- >$$F.$$arg.byte.result 2>&1; \
- $(DIFF) $$F.$$arg.byte.reference $$F.$$arg.byte.result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done; \
- done
- @for file in $(OTHERFILES) $(OTHERFILESNOINLINING); do \
- rm -f program program.exe; \
- $(OCAMLC) -g -o $(EXECNAME) $$file; \
- printf " ... testing '$$file' with ocamlc:"; \
- F="`basename $$file .ml`"; \
- (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
- $(OCAMLRUN) $(EXECNAME) $$arg || true) \
- >$$F.byte.result 2>&1; \
- $(DIFF) $$F.byte.reference $$F.byte.result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done;
- @for file in $(INLININGFILES); \
- do \
- rm -f program program.exe; \
- $(OCAMLC) -g -o $(EXECNAME) $$file; \
- printf " ... testing '$$file' with ocamlc:"; \
- F="`basename $$file .ml`"; \
- (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
- $(OCAMLRUN) $(EXECNAME) $$arg 2>&1 || true) \
- | $(LOCATIONFILTER) >$$F.byte.result 2>&1; \
- $(DIFF) $$F.byte.reference $$F.byte.result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done
-
-.PHONY: skip
-skip:
- @for file in $(ABCDFILES); do \
- for arg in a b c d ''; do \
- echo " ... testing '$$file' with ocamlopt and argument '$$arg': \
- => skipped"; \
- done; \
- done
- @for file in $(OTHERFILES) $(OTHERFILESNOINLINING) \
- $(OTHERFILESNOINLINING_NATIVE) $(INLININGFILES); do \
- echo " ... testing '$$file' with ocamlopt: => skipped"; \
- done
-
-.PHONY: native
-native:
- @for file in $(ABCDFILES); do \
- rm -f program program.exe; \
- $(OCAMLOPT) -g -o $(EXECNAME) $$file; \
- for arg in a b c d ''; do \
- printf " ... testing '$$file' with ocamlopt and argument '$$arg':";\
- F="`basename $$file .ml`"; \
- (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
- ./$(EXECNAME) $$arg || true) \
- >$$F.$$arg.native.result 2>&1; \
- $(DIFF) $$F.$$arg.native.reference $$F.$$arg.native.result \
- >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done; \
- done
- @for file in $(OTHERFILES); do \
- rm -f program program.exe; \
- $(OCAMLOPT) -g -o $(EXECNAME) $$file; \
- printf " ... testing '$$file' with ocamlopt:"; \
- F="`basename $$file .ml`"; \
- (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
- ./$(EXECNAME) $$arg || true) \
- >$$F.native.result 2>&1; \
- $(DIFF) $$F.native.reference $$F.native.result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done;
- @for file in $(OTHERFILESNOINLINING) $(OTHERFILESNOINLINING_NATIVE); \
- do \
- rm -f program program.exe; \
- $(OCAMLOPT) -inline 0 -g -o $(EXECNAME) $$file; \
- printf " ... testing '$$file' with ocamlopt:"; \
- F="`basename $$file .ml`"; \
- (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
- ./$(EXECNAME) $$arg || true) \
- >$$F.native.result 2>&1; \
- $(DIFF) $$F.native.reference $$F.native.result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done;
- @for file in $(INLININGFILES); \
- do \
- rm -f program program.exe; \
- $(OCAMLOPT) -g -o $(EXECNAME) $$file; \
- printf " ... testing '$$file' with ocamlopt:"; \
- F="`basename $$file .ml`"; \
- (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
- ./$(EXECNAME) $$arg 2>&1 || true) \
- | $(LOCATIONFILTER) >$$F.native.result; \
- $(DIFF) $$F.native.reference $$F.native.result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- rm -f program program.exe; \
- $(OCAMLOPT) -g -o $(EXECNAME) -O3 $$file; \
- printf " ... testing '$$file' with ocamlopt -O3:"; \
- F="`basename $$file .ml`"; \
- (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
- ./$(EXECNAME) $$arg 2>&1 || true) \
- | $(LOCATIONFILTER) >$$F.O3.result; \
- $(DIFF) $$F.native.reference $$F.O3.result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done
-
-
-.PHONY: promote
-promote: defaultpromote
-
-.PHONY: clean
-clean: defaultclean
- @rm -f *.result program program.exe
-
-include $(BASEDIR)/makefiles/Makefile.common
+++ /dev/null
-Fatal error: exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace.ml", line 18, characters 12-24
+++ /dev/null
-Fatal error: exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace.ml", line 18, characters 12-24
+++ /dev/null
-b
-Fatal error: exception Backtrace.Error("b")
-Raised at file "backtrace.ml", line 7, characters 21-32
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 11, characters 4-11
-Re-raised at file "backtrace.ml", line 13, characters 68-71
-Called from file "backtrace.ml", line 18, characters 9-25
+++ /dev/null
-b
-Fatal error: exception Backtrace.Error("b")
-Raised at file "backtrace.ml", line 7, characters 16-32
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 11, characters 4-11
-Re-raised at file "backtrace.ml", line 13, characters 62-71
-Called from file "backtrace.ml", line 18, characters 9-25
--- /dev/null
+a
+b
+Fatal error: exception Backtrace.Error("b")
+Raised at file "backtrace.ml", line 16, characters 21-32
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 20, characters 4-11
+Re-raised at file "backtrace.ml", line 22, characters 68-71
+Called from file "backtrace.ml", line 27, characters 9-25
+Fatal error: exception Backtrace.Error("c")
+Raised at file "backtrace.ml", line 23, characters 26-37
+Called from file "backtrace.ml", line 27, characters 9-25
+Fatal error: exception Backtrace.Error("d")
+Raised at file "backtrace.ml", line 16, characters 21-32
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 20, characters 4-11
+Called from file "backtrace.ml", line 27, characters 9-25
+Fatal error: exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace.ml", line 27, characters 12-24
+++ /dev/null
-Fatal error: exception Backtrace.Error("c")
-Raised at file "backtrace.ml", line 14, characters 26-37
-Called from file "backtrace.ml", line 18, characters 9-25
+++ /dev/null
-Fatal error: exception Backtrace.Error("c")
-Raised at file "backtrace.ml", line 14, characters 20-37
-Called from file "backtrace.ml", line 18, characters 9-25
+++ /dev/null
-Fatal error: exception Backtrace.Error("d")
-Raised at file "backtrace.ml", line 7, characters 21-32
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 11, characters 4-11
-Called from file "backtrace.ml", line 18, characters 9-25
+++ /dev/null
-Fatal error: exception Backtrace.Error("d")
-Raised at file "backtrace.ml", line 7, characters 16-32
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 11, characters 4-11
-Called from file "backtrace.ml", line 18, characters 9-25
+(* TEST
+ flags = "-g"
+ ocamlrunparam += ",b=1"
+ * bytecode
+ reference = "${test_source_directory}/backtrace.byte.reference"
+ * native
+ reference = "${test_source_directory}/backtrace.opt.reference"
+ compare_programs = "false"
+*)
(* A test for stack backtraces *)
--- /dev/null
+a
+b
+Fatal error: exception Backtrace.Error("b")
+Raised at file "backtrace.ml", line 16, characters 16-32
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 20, characters 4-11
+Re-raised at file "backtrace.ml", line 22, characters 62-71
+Called from file "backtrace.ml", line 27, characters 9-25
+Fatal error: exception Backtrace.Error("c")
+Raised at file "backtrace.ml", line 23, characters 20-37
+Called from file "backtrace.ml", line 27, characters 9-25
+Fatal error: exception Backtrace.Error("d")
+Raised at file "backtrace.ml", line 16, characters 16-32
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 16, characters 42-53
+Called from file "backtrace.ml", line 20, characters 4-11
+Called from file "backtrace.ml", line 27, characters 9-25
+Fatal error: exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace.ml", line 27, characters 12-24
--- /dev/null
+#!/bin/sh
+# Run the backtrace test
+
+exec > "${output}" 2>&1
+
+for arg in a b c d ''; do
+ "${program}" ${arg} || true
+done
No exception
b
Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 8, characters 23-34
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 13, characters 4-11
-Re-raised at file "backtrace2.ml", line 15, characters 68-71
-Called from file "backtrace2.ml", line 58, characters 11-23
+Raised at file "backtrace2.ml", line 17, characters 23-34
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 22, characters 4-11
+Re-raised at file "backtrace2.ml", line 24, characters 68-71
+Called from file "backtrace2.ml", line 67, characters 11-23
Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 16, characters 26-37
-Called from file "backtrace2.ml", line 58, characters 11-23
+Raised at file "backtrace2.ml", line 25, characters 26-37
+Called from file "backtrace2.ml", line 67, characters 11-23
Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 8, characters 23-34
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 13, characters 4-11
-Called from file "backtrace2.ml", line 58, characters 11-23
+Raised at file "backtrace2.ml", line 17, characters 23-34
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 22, characters 4-11
+Called from file "backtrace2.ml", line 67, characters 11-23
e
Uncaught exception Backtrace2.Error("e")
-Raised at file "backtrace2.ml", line 22, characters 56-59
-Called from file "backtrace2.ml", line 58, characters 11-23
+Raised at file "backtrace2.ml", line 31, characters 56-59
+Called from file "backtrace2.ml", line 67, characters 11-23
f
Uncaught exception Backtrace2.Error("f")
-Raised at file "backtrace2.ml", line 28, characters 68-71
-Called from file "backtrace2.ml", line 58, characters 11-23
+Raised at file "backtrace2.ml", line 37, characters 68-71
+Called from file "backtrace2.ml", line 67, characters 11-23
Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 58, characters 14-22
+Raised by primitive operation at file "backtrace2.ml", line 67, characters 14-22
test_Not_found
Uncaught exception Not_found
Raised at file "hashtbl.ml", line 194, characters 19-28
-Called from file "backtrace2.ml", line 39, characters 9-42
-Re-raised at file "backtrace2.ml", line 39, characters 67-70
-Called from file "backtrace2.ml", line 58, characters 11-23
+Called from file "backtrace2.ml", line 48, characters 9-42
+Re-raised at file "backtrace2.ml", line 48, characters 67-70
+Called from file "backtrace2.ml", line 67, characters 11-23
Uncaught exception Not_found
-Raised at file "backtrace2.ml", line 43, characters 24-33
-Called from file "backtrace2.ml", line 43, characters 43-52
-Called from file "backtrace2.ml", line 43, characters 43-52
-Called from file "backtrace2.ml", line 43, characters 43-52
-Called from file "backtrace2.ml", line 43, characters 43-52
-Called from file "backtrace2.ml", line 43, characters 43-52
+Raised at file "backtrace2.ml", line 52, characters 24-33
+Called from file "backtrace2.ml", line 52, characters 43-52
+Called from file "backtrace2.ml", line 52, characters 43-52
+Called from file "backtrace2.ml", line 52, characters 43-52
+Called from file "backtrace2.ml", line 52, characters 43-52
+Called from file "backtrace2.ml", line 52, characters 43-52
Called from file "camlinternalLazy.ml", line 27, characters 17-27
Re-raised at file "camlinternalLazy.ml", line 34, characters 10-11
-Called from file "backtrace2.ml", line 58, characters 11-23
+Called from file "backtrace2.ml", line 67, characters 11-23
Uncaught exception Not_found
Raised at file "hashtbl.ml", line 194, characters 19-28
-Called from file "backtrace2.ml", line 46, characters 8-41
+Called from file "backtrace2.ml", line 55, characters 8-41
Re-raised at file "camlinternalLazy.ml", line 33, characters 62-63
Called from file "camlinternalLazy.ml", line 27, characters 17-27
Re-raised at file "camlinternalLazy.ml", line 34, characters 10-11
-Called from file "backtrace2.ml", line 58, characters 11-23
+Called from file "backtrace2.ml", line 67, characters 11-23
+(* TEST
+ flags = "-g"
+ ocamlrunparam += ",b=1"
+ * bytecode
+ reference = "${test_source_directory}/backtrace2.byte.reference"
+ * native
+ reference = "${test_source_directory}/backtrace2.opt.reference"
+ compare_programs = "false"
+*)
(* A test for stack backtraces *)
+++ /dev/null
-a
-No exception
-b
-Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 8, characters 18-34
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 13, characters 4-11
-Re-raised at file "backtrace2.ml", line 15, characters 62-71
-Called from file "backtrace2.ml", line 58, characters 11-23
-Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 16, characters 20-37
-Called from file "backtrace2.ml", line 58, characters 11-23
-Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 8, characters 18-34
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 8, characters 44-55
-Called from file "backtrace2.ml", line 13, characters 4-11
-Called from file "backtrace2.ml", line 58, characters 11-23
-e
-Uncaught exception Backtrace2.Error("e")
-Raised at file "backtrace2.ml", line 22, characters 50-59
-Called from file "backtrace2.ml", line 58, characters 11-23
-f
-Uncaught exception Backtrace2.Error("f")
-Raised at file "backtrace2.ml", line 28, characters 62-71
-Called from file "backtrace2.ml", line 58, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 58, characters 14-22
-test_Not_found
-Uncaught exception Not_found
-Raised at file "hashtbl.ml", line 194, characters 13-28
-Called from file "backtrace2.ml", line 39, characters 9-42
-Re-raised at file "backtrace2.ml", line 39, characters 61-70
-Called from file "backtrace2.ml", line 58, characters 11-23
-Uncaught exception Not_found
-Raised at file "backtrace2.ml", line 43, characters 18-33
-Called from file "backtrace2.ml", line 43, characters 43-52
-Called from file "backtrace2.ml", line 43, characters 43-52
-Called from file "backtrace2.ml", line 43, characters 43-52
-Called from file "backtrace2.ml", line 43, characters 43-52
-Called from file "backtrace2.ml", line 43, characters 43-52
-Called from file "camlinternalLazy.ml", line 27, characters 17-27
-Re-raised at file "camlinternalLazy.ml", line 34, characters 4-11
-Called from file "backtrace2.ml", line 58, characters 11-23
-Uncaught exception Not_found
-Raised at file "hashtbl.ml", line 194, characters 13-28
-Called from file "backtrace2.ml", line 46, characters 8-41
-Re-raised at file "camlinternalLazy.ml", line 33, characters 56-63
-Called from file "camlinternalLazy.ml", line 27, characters 17-27
-Re-raised at file "camlinternalLazy.ml", line 34, characters 4-11
-Called from file "backtrace2.ml", line 58, characters 11-23
--- /dev/null
+a
+No exception
+b
+Uncaught exception Backtrace2.Error("b")
+Raised at file "backtrace2.ml", line 17, characters 18-34
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 22, characters 4-11
+Re-raised at file "backtrace2.ml", line 24, characters 62-71
+Called from file "backtrace2.ml", line 67, characters 11-23
+Uncaught exception Backtrace2.Error("c")
+Raised at file "backtrace2.ml", line 25, characters 20-37
+Called from file "backtrace2.ml", line 67, characters 11-23
+Uncaught exception Backtrace2.Error("d")
+Raised at file "backtrace2.ml", line 17, characters 18-34
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 17, characters 44-55
+Called from file "backtrace2.ml", line 22, characters 4-11
+Called from file "backtrace2.ml", line 67, characters 11-23
+e
+Uncaught exception Backtrace2.Error("e")
+Raised at file "backtrace2.ml", line 31, characters 50-59
+Called from file "backtrace2.ml", line 67, characters 11-23
+f
+Uncaught exception Backtrace2.Error("f")
+Raised at file "backtrace2.ml", line 37, characters 62-71
+Called from file "backtrace2.ml", line 67, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace2.ml", line 67, characters 14-22
+test_Not_found
+Uncaught exception Not_found
+Raised at file "hashtbl.ml", line 194, characters 13-28
+Called from file "backtrace2.ml", line 48, characters 9-42
+Re-raised at file "backtrace2.ml", line 48, characters 61-70
+Called from file "backtrace2.ml", line 67, characters 11-23
+Uncaught exception Not_found
+Raised at file "backtrace2.ml", line 52, characters 18-33
+Called from file "backtrace2.ml", line 52, characters 43-52
+Called from file "backtrace2.ml", line 52, characters 43-52
+Called from file "backtrace2.ml", line 52, characters 43-52
+Called from file "backtrace2.ml", line 52, characters 43-52
+Called from file "backtrace2.ml", line 52, characters 43-52
+Called from file "camlinternalLazy.ml", line 27, characters 17-27
+Re-raised at file "camlinternalLazy.ml", line 34, characters 4-11
+Called from file "backtrace2.ml", line 67, characters 11-23
+Uncaught exception Not_found
+Raised at file "hashtbl.ml", line 194, characters 13-28
+Called from file "backtrace2.ml", line 55, characters 8-41
+Re-raised at file "camlinternalLazy.ml", line 33, characters 56-63
+Called from file "camlinternalLazy.ml", line 27, characters 17-27
+Re-raised at file "camlinternalLazy.ml", line 34, characters 4-11
+Called from file "backtrace2.ml", line 67, characters 11-23
No exception
b
Uncaught exception Backtrace3.Error("b")
-Raised at file "backtrace3.ml", line 7, characters 21-32
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 11, characters 4-11
-Re-raised at file "backtrace3.ml", line 20, characters 47-50
-Called from file "backtrace3.ml", line 28, characters 11-23
+Raised at file "backtrace3.ml", line 16, characters 21-32
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 20, characters 4-11
+Re-raised at file "backtrace3.ml", line 29, characters 47-50
+Called from file "backtrace3.ml", line 54, characters 11-23
+c
Uncaught exception Backtrace3.Error("c")
-Raised at file "backtrace3.ml", line 24, characters 12-23
-Called from file "backtrace3.ml", line 28, characters 11-23
+Raised at file "backtrace3.ml", line 33, characters 47-58
+Called from file "backtrace3.ml", line 54, characters 11-23
+d
Uncaught exception Backtrace3.Error("d")
-Raised at file "backtrace3.ml", line 7, characters 21-32
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 11, characters 4-11
-Called from file "backtrace3.ml", line 28, characters 11-23
+Raised at file "backtrace3.ml", line 16, characters 21-32
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 20, characters 4-11
+Re-raised at file "backtrace3.ml", line 36, characters 47-50
+Called from file "backtrace3.ml", line 54, characters 11-23
+e
+Uncaught exception Backtrace3.Error("e")
+Raised at file "backtrace3.ml", line 16, characters 21-32
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 20, characters 4-11
+Re-raised at file "backtrace3.ml", line 39, characters 47-51
+Called from file "backtrace3.ml", line 54, characters 11-23
+f
+Uncaught exception Backtrace3.Error("f")
+Raised at file "backtrace3.ml", line 16, characters 21-32
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 20, characters 4-11
+Re-raised at file "backtrace3.ml", line 44, characters 51-54
+Called from file "backtrace3.ml", line 54, characters 11-23
+g
+Uncaught exception Backtrace3.Error("g")
+Raised at file "backtrace3.ml", line 16, characters 21-32
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 20, characters 4-11
+Re-raised at file "backtrace3.ml", line 47, characters 51-55
+Called from file "backtrace3.ml", line 54, characters 11-23
+Uncaught exception Backtrace3.Error("h")
+Raised at file "backtrace3.ml", line 50, characters 16-17
+Called from file "backtrace3.ml", line 54, characters 11-23
Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace3.ml", line 28, characters 14-22
+Raised by primitive operation at file "backtrace3.ml", line 54, characters 14-22
+(* TEST
+ flags = "-g"
+ ocamlrunparam += ",b=1"
+ * bytecode
+ reference = "${test_source_directory}/backtrace3.byte.reference"
+ * native
+ reference = "${test_source_directory}/backtrace3.opt.reference"
+ compare_programs = "false"
+*)
(* A test for stack backtraces *)
| exception (Error "c") ->
(* according to the current re-raise policy (a static condition),
this does not re-raise *)
- raise (Error "c")
+ print_string "c"; print_newline(); raise (Error "c")
+ | exception (Error "d" as exn as _exn2) ->
+ (* this should Re-raise, appending to the current backtrace *)
+ print_string "d"; print_newline(); raise exn
+ | exception (Error "e" as _exn as exn2) ->
+ (* this should Re-raise, appending to the current backtrace *)
+ print_string "e"; print_newline(); raise exn2
+ | exception (exn as exn2) ->
+ match exn with
+ | Error "f" ->
+ (* this should Re-raise, appending to the current backtrace *)
+ print_string "f"; print_newline(); raise exn
+ | Error "g" ->
+ (* this should Re-raise, appending to the current backtrace *)
+ print_string "g"; print_newline(); raise exn2
+ | x ->
+ (* this should *not* Re-raise *)
+ raise x
let run args =
try
run [| "b" |];
run [| "c" |];
run [| "d" |];
+ run [| "e" |];
+ run [| "f" |];
+ run [| "g" |];
+ run [| "h" |];
run [| |]
+++ /dev/null
-a
-No exception
-b
-Uncaught exception Backtrace3.Error("b")
-Raised at file "backtrace3.ml", line 7, characters 16-32
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 11, characters 4-11
-Re-raised at file "backtrace3.ml", line 20, characters 41-50
-Called from file "backtrace3.ml", line 28, characters 11-23
-Uncaught exception Backtrace3.Error("c")
-Raised at file "backtrace3.ml", line 24, characters 6-23
-Called from file "backtrace3.ml", line 28, characters 11-23
-Uncaught exception Backtrace3.Error("d")
-Raised at file "backtrace3.ml", line 7, characters 16-32
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 11, characters 4-11
-Called from file "backtrace3.ml", line 28, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace3.ml", line 28, characters 14-22
--- /dev/null
+a
+No exception
+b
+Uncaught exception Backtrace3.Error("b")
+Raised at file "backtrace3.ml", line 16, characters 16-32
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 20, characters 4-11
+Re-raised at file "backtrace3.ml", line 29, characters 41-50
+Called from file "backtrace3.ml", line 54, characters 11-23
+c
+Uncaught exception Backtrace3.Error("c")
+Raised at file "backtrace3.ml", line 33, characters 41-58
+Called from file "backtrace3.ml", line 54, characters 11-23
+d
+Uncaught exception Backtrace3.Error("d")
+Raised at file "backtrace3.ml", line 16, characters 16-32
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 20, characters 4-11
+Re-raised at file "backtrace3.ml", line 36, characters 41-50
+Called from file "backtrace3.ml", line 54, characters 11-23
+e
+Uncaught exception Backtrace3.Error("e")
+Raised at file "backtrace3.ml", line 16, characters 16-32
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 20, characters 4-11
+Re-raised at file "backtrace3.ml", line 39, characters 41-51
+Called from file "backtrace3.ml", line 54, characters 11-23
+f
+Uncaught exception Backtrace3.Error("f")
+Raised at file "backtrace3.ml", line 16, characters 16-32
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 20, characters 4-11
+Re-raised at file "backtrace3.ml", line 44, characters 45-54
+Called from file "backtrace3.ml", line 54, characters 11-23
+g
+Uncaught exception Backtrace3.Error("g")
+Raised at file "backtrace3.ml", line 16, characters 16-32
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 16, characters 42-53
+Called from file "backtrace3.ml", line 20, characters 4-11
+Re-raised at file "backtrace3.ml", line 47, characters 45-55
+Called from file "backtrace3.ml", line 54, characters 11-23
+Uncaught exception Backtrace3.Error("h")
+Raised at file "backtrace3.ml", line 50, characters 10-17
+Called from file "backtrace3.ml", line 54, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace3.ml", line 54, characters 14-22
No exception
b
Uncaught exception Backtrace_deprecated.Error("b")
-Raised at file "backtrace_deprecated.ml", line 10, characters 21-32
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 14, characters 4-11
-Re-raised at file "backtrace_deprecated.ml", line 16, characters 68-71
-Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Raised at file "backtrace_deprecated.ml", line 19, characters 21-32
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 23, characters 4-11
+Re-raised at file "backtrace_deprecated.ml", line 25, characters 68-71
+Called from file "backtrace_deprecated.ml", line 30, characters 11-23
Uncaught exception Backtrace_deprecated.Error("c")
-Raised at file "backtrace_deprecated.ml", line 17, characters 26-37
-Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Raised at file "backtrace_deprecated.ml", line 26, characters 26-37
+Called from file "backtrace_deprecated.ml", line 30, characters 11-23
Uncaught exception Backtrace_deprecated.Error("d")
-Raised at file "backtrace_deprecated.ml", line 10, characters 21-32
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 14, characters 4-11
-Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Raised at file "backtrace_deprecated.ml", line 19, characters 21-32
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 23, characters 4-11
+Called from file "backtrace_deprecated.ml", line 30, characters 11-23
Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace_deprecated.ml", line 21, characters 14-22
+Raised by primitive operation at file "backtrace_deprecated.ml", line 30, characters 14-22
+(* TEST
+ flags = "-g"
+ ocamlrunparam += ",b=1"
+ * bytecode
+ reference = "${test_source_directory}/backtrace_deprecated.byte.reference"
+ * native
+ reference = "${test_source_directory}/backtrace_deprecated.opt.reference"
+ compare_programs = "false"
+*)
(* A test for stack backtraces *)
+++ /dev/null
-a
-No exception
-b
-Uncaught exception Backtrace_deprecated.Error("b")
-Raised at file "backtrace_deprecated.ml", line 10, characters 16-32
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 14, characters 4-11
-Re-raised at file "backtrace_deprecated.ml", line 16, characters 62-71
-Called from file "backtrace_deprecated.ml", line 21, characters 11-23
-Uncaught exception Backtrace_deprecated.Error("c")
-Raised at file "backtrace_deprecated.ml", line 17, characters 20-37
-Called from file "backtrace_deprecated.ml", line 21, characters 11-23
-Uncaught exception Backtrace_deprecated.Error("d")
-Raised at file "backtrace_deprecated.ml", line 10, characters 16-32
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 14, characters 4-11
-Called from file "backtrace_deprecated.ml", line 21, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace_deprecated.ml", line 21, characters 14-22
--- /dev/null
+a
+No exception
+b
+Uncaught exception Backtrace_deprecated.Error("b")
+Raised at file "backtrace_deprecated.ml", line 19, characters 16-32
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 23, characters 4-11
+Re-raised at file "backtrace_deprecated.ml", line 25, characters 62-71
+Called from file "backtrace_deprecated.ml", line 30, characters 11-23
+Uncaught exception Backtrace_deprecated.Error("c")
+Raised at file "backtrace_deprecated.ml", line 26, characters 20-37
+Called from file "backtrace_deprecated.ml", line 30, characters 11-23
+Uncaught exception Backtrace_deprecated.Error("d")
+Raised at file "backtrace_deprecated.ml", line 19, characters 16-32
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 19, characters 42-53
+Called from file "backtrace_deprecated.ml", line 23, characters 4-11
+Called from file "backtrace_deprecated.ml", line 30, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace_deprecated.ml", line 30, characters 14-22
No exception
b
Uncaught exception Backtrace_slots.Error("b")
-Raised at file "backtrace_slots.ml", line 36, characters 21-32
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 40, characters 4-11
-Re-raised at file "backtrace_slots.ml", line 42, characters 68-71
-Called from file "backtrace_slots.ml", line 47, characters 11-23
+Raised at file "backtrace_slots.ml", line 45, characters 21-32
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 49, characters 4-11
+Re-raised at file "backtrace_slots.ml", line 51, characters 68-71
+Called from file "backtrace_slots.ml", line 56, characters 11-23
Uncaught exception Backtrace_slots.Error("c")
-Raised at file "backtrace_slots.ml", line 43, characters 26-37
-Called from file "backtrace_slots.ml", line 47, characters 11-23
+Raised at file "backtrace_slots.ml", line 52, characters 26-37
+Called from file "backtrace_slots.ml", line 56, characters 11-23
Uncaught exception Backtrace_slots.Error("d")
-Raised at file "backtrace_slots.ml", line 36, characters 21-32
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 40, characters 4-11
-Called from file "backtrace_slots.ml", line 47, characters 11-23
+Raised at file "backtrace_slots.ml", line 45, characters 21-32
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 49, characters 4-11
+Called from file "backtrace_slots.ml", line 56, characters 11-23
Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace_slots.ml", line 47, characters 14-22
+Raised by primitive operation at file "backtrace_slots.ml", line 56, characters 14-22
+(* TEST
+ flags = "-g"
+ ocamlrunparam += ",b=1"
+ * bytecode
+ reference = "${test_source_directory}/backtrace_slots.byte.reference"
+ * native
+ reference = "${test_source_directory}/backtrace_slots.opt.reference"
+ compare_programs = "false"
+*)
(* A test for stack backtraces *)
+++ /dev/null
-a
-No exception
-b
-Uncaught exception Backtrace_slots.Error("b")
-Raised at file "backtrace_slots.ml", line 36, characters 16-32
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 40, characters 4-11
-Re-raised at file "backtrace_slots.ml", line 42, characters 62-71
-Called from file "backtrace_slots.ml", line 47, characters 11-23
-Uncaught exception Backtrace_slots.Error("c")
-Raised at file "backtrace_slots.ml", line 43, characters 20-37
-Called from file "backtrace_slots.ml", line 47, characters 11-23
-Uncaught exception Backtrace_slots.Error("d")
-Raised at file "backtrace_slots.ml", line 36, characters 16-32
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 40, characters 4-11
-Called from file "backtrace_slots.ml", line 47, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace_slots.ml", line 47, characters 14-22
--- /dev/null
+a
+No exception
+b
+Uncaught exception Backtrace_slots.Error("b")
+Raised at file "backtrace_slots.ml", line 45, characters 16-32
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 49, characters 4-11
+Re-raised at file "backtrace_slots.ml", line 51, characters 62-71
+Called from file "backtrace_slots.ml", line 56, characters 11-23
+Uncaught exception Backtrace_slots.Error("c")
+Raised at file "backtrace_slots.ml", line 52, characters 20-37
+Called from file "backtrace_slots.ml", line 56, characters 11-23
+Uncaught exception Backtrace_slots.Error("d")
+Raised at file "backtrace_slots.ml", line 45, characters 16-32
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 45, characters 42-53
+Called from file "backtrace_slots.ml", line 49, characters 4-11
+Called from file "backtrace_slots.ml", line 56, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace_slots.ml", line 56, characters 14-22
+(* TEST
+ flags = "-g -inline 0"
+ ocamlrunparam += ",b=1"
+ compare_programs = "false"
+ * native
+*)
let () = Printexc.record_backtrace true
--- /dev/null
+#!/bin/sh
+grep -oE '[a-zA-Z_]+\.ml(:[0-9]+)?|(line|characters) [0-9-]+'
inline_test.ml
-line 5
+line 19
characters 8-24
inline_test.ml
-line 8
+line 22
characters 2-5
inline_test.ml
-line 11
+line 25
characters 12-17
inline_test.ml
-line 14
+line 28
characters 5-8
inline_test.ml
-line 18
+line 32
characters 2-6
+(* TEST
+ flags = "-g"
+ ocamlrunparam += ",b=1"
+ * bytecode
+ reference = "${test_source_directory}/inline_test.byte.reference"
+ * native
+ reference = "${test_source_directory}/inline_test.opt.reference"
+ compare_programs = "false"
+ * native
+ ocamlopt_flags = "-O3"
+ compiler_directory_suffix = ".O3"
+ reference = "${test_source_directory}/inline_test.opt.reference"
+ compare_programs = "false"
+*)
(* A test for inlined stack backtraces *)
+++ /dev/null
-inline_test.ml
-line 5
-characters 2-24
-inline_test.ml
-line 8
-characters 2-5
-inline_test.ml
-line 11
-characters 12-17
-inline_test.ml
-line 14
-characters 5-8
-inline_test.ml
-line 18
-characters 2-6
--- /dev/null
+inline_test.ml
+line 19
+characters 2-24
+inline_test.ml
+line 22
+characters 2-5
+inline_test.ml
+line 25
+characters 12-17
+inline_test.ml
+line 28
+characters 5-8
+inline_test.ml
+line 32
+characters 2-6
--- /dev/null
+#!/bin/sh
+(${program} 2>&1 || true) | \
+ ${test_source_directory}/filter-locations.sh > ${output}
-inline_traversal_test.ml:5
-inline_traversal_test.ml:8
-inline_traversal_test.ml:11
-inline_traversal_test.ml:14
inline_traversal_test.ml:19
+inline_traversal_test.ml:22
+inline_traversal_test.ml:25
+inline_traversal_test.ml:28
+inline_traversal_test.ml:33
+(* TEST
+ flags = "-g"
+ ocamlrunparam += ",b=1"
+ * bytecode
+ reference = "${test_source_directory}/inline_traversal_test.byte.reference"
+ * native
+ reference = "${test_source_directory}/inline_traversal_test.opt.reference"
+ compare_programs = "false"
+ * native
+ ocamlopt_flags = "-O3"
+ compiler_directory_suffix = ".O3"
+ reference = "${test_source_directory}/inline_traversal_test.opt.reference"
+ compare_programs = "false"
+*)
(* A test for inlined stack backtraces *)
+++ /dev/null
-inline_traversal_test.ml:5
-inline_traversal_test.ml:8
-inline_traversal_test.ml:11
-inline_traversal_test.ml:14
-inline_traversal_test.ml:19
--- /dev/null
+inline_traversal_test.ml:19
+inline_traversal_test.ml:22
+inline_traversal_test.ml:25
+inline_traversal_test.ml:28
+inline_traversal_test.ml:33
--- /dev/null
+#!/bin/sh
+(${program} 2>&1 || true) | \
+ ${test_source_directory}/filter-locations.sh > ${output}
--- /dev/null
+backtrace.ml
+backtrace2.ml
+backtrace3.ml
+backtrace_deprecated.ml
+backtrace_slots.ml
+backtraces_and_finalizers.ml
+inline_test.ml
+inline_traversal_test.ml
+pr6920_why_at.ml
+pr6920_why_swallow.ml
+raw_backtrace.ml
-Fatal error: exception Pervasives.Exit
-Raised at file "pr6920_why_at.ml", line 1, characters 41-45
-Called from file "pr6920_why_at.ml", line 3, characters 2-11
-Called from file "pr6920_why_at.ml", line 9, characters 2-6
+Fatal error: exception Stdlib.Pervasives.Exit
+Raised at file "pr6920_why_at.ml", line 13, characters 41-45
+Called from file "pr6920_why_at.ml", line 15, characters 2-11
+Called from file "pr6920_why_at.ml", line 21, characters 2-6
+(* TEST
+ flags = "-g"
+ ocamlrunparam += ",b=1"
+ ocamlopt_flags = "-inline 0"
+ exit_status = "2"
+ * bytecode
+ reference = "${test_source_directory}/pr6920_why_at.byte.reference"
+ * native
+ reference = "${test_source_directory}/pr6920_why_at.opt.reference"
+ compare_programs = "false"
+*)
+
let why : unit -> unit = fun () -> raise Exit [@@inline never]
let f () =
why @@ ();
+++ /dev/null
-Fatal error: exception Pervasives.Exit
-Raised at file "pr6920_why_at.ml", line 1, characters 35-45
-Called from file "pr6920_why_at.ml", line 3, characters 2-11
-Called from file "pr6920_why_at.ml", line 9, characters 2-6
--- /dev/null
+Fatal error: exception Stdlib.Pervasives.Exit
+Raised at file "pr6920_why_at.ml", line 13, characters 35-45
+Called from file "pr6920_why_at.ml", line 15, characters 2-11
+Called from file "pr6920_why_at.ml", line 21, characters 2-6
-Fatal error: exception Pervasives.Exit
-Raised at file "pr6920_why_swallow.ml", line 1, characters 41-45
-Called from file "pr6920_why_swallow.ml", line 4, characters 4-13
-Called from file "pr6920_why_swallow.ml", line 11, characters 2-6
+Fatal error: exception Stdlib.Pervasives.Exit
+Raised at file "pr6920_why_swallow.ml", line 13, characters 41-45
+Called from file "pr6920_why_swallow.ml", line 16, characters 4-13
+Called from file "pr6920_why_swallow.ml", line 23, characters 2-6
+(* TEST
+ flags = "-g"
+ ocamlrunparam += ",b=1"
+ ocamlopt_flags = "-inline 0"
+ exit_status = "2"
+ * bytecode
+ reference = "${test_source_directory}/pr6920_why_swallow.byte.reference"
+ * native
+ reference = "${test_source_directory}/pr6920_why_swallow.opt.reference"
+ compare_programs = "false"
+*)
+
let why : unit -> unit = fun () -> raise Exit [@@inline never]
let f () =
for i = 1 to 10 do
+++ /dev/null
-Fatal error: exception Pervasives.Exit
-Raised at file "pr6920_why_swallow.ml", line 1, characters 35-45
-Called from file "pr6920_why_swallow.ml", line 4, characters 4-13
-Called from file "pr6920_why_swallow.ml", line 11, characters 2-6
--- /dev/null
+Fatal error: exception Stdlib.Pervasives.Exit
+Raised at file "pr6920_why_swallow.ml", line 13, characters 35-45
+Called from file "pr6920_why_swallow.ml", line 16, characters 4-13
+Called from file "pr6920_why_swallow.ml", line 23, characters 2-6
No exception
b
Uncaught exception Raw_backtrace.Error("b")
-Raised at file "raw_backtrace.ml", line 7, characters 21-32
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 16, characters 4-11
-Re-raised at file "raw_backtrace.ml", line 18, characters 68-71
-Called from file "raw_backtrace.ml", line 33, characters 11-23
+Raised at file "raw_backtrace.ml", line 16, characters 21-32
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 25, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 27, characters 68-71
+Called from file "raw_backtrace.ml", line 42, characters 11-23
Uncaught exception Raw_backtrace.Error("c")
-Raised at file "raw_backtrace.ml", line 19, characters 26-37
-Called from file "raw_backtrace.ml", line 33, characters 11-23
+Raised at file "raw_backtrace.ml", line 28, characters 26-37
+Called from file "raw_backtrace.ml", line 42, characters 11-23
Uncaught exception Raw_backtrace.Error("d")
-Raised at file "raw_backtrace.ml", line 7, characters 21-32
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 16, characters 4-11
-Called from file "raw_backtrace.ml", line 33, characters 11-23
+Raised at file "raw_backtrace.ml", line 16, characters 21-32
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 25, characters 4-11
+Called from file "raw_backtrace.ml", line 42, characters 11-23
e
Uncaught exception Raw_backtrace.Error("e")
-Raised at file "raw_backtrace.ml", line 7, characters 21-32
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 16, characters 4-11
-Re-raised at file "raw_backtrace.ml", line 25, characters 39-42
-Called from file "raw_backtrace.ml", line 33, characters 11-23
+Raised at file "raw_backtrace.ml", line 16, characters 21-32
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 25, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 34, characters 39-42
+Called from file "raw_backtrace.ml", line 42, characters 11-23
f
Uncaught exception Raw_backtrace.Localized(_)
-Raised at file "raw_backtrace.ml", line 7, characters 21-32
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 16, characters 4-11
-Re-raised at file "raw_backtrace.ml", line 29, characters 39-54
-Called from file "raw_backtrace.ml", line 33, characters 11-23
+Raised at file "raw_backtrace.ml", line 16, characters 21-32
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 25, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 38, characters 39-54
+Called from file "raw_backtrace.ml", line 42, characters 11-23
Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "raw_backtrace.ml", line 33, characters 14-22
+Raised by primitive operation at file "raw_backtrace.ml", line 42, characters 14-22
+(* TEST
+ flags = "-g"
+ ocamlrunparam += ",b=1"
+ * bytecode
+ reference = "${test_source_directory}/raw_backtrace.byte.reference"
+ * native
+ reference = "${test_source_directory}/raw_backtrace.opt.reference"
+ compare_programs = "false"
+*)
(* A test for stack backtraces *)
+++ /dev/null
-a
-No exception
-b
-Uncaught exception Raw_backtrace.Error("b")
-Raised at file "raw_backtrace.ml", line 7, characters 16-32
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 16, characters 4-11
-Re-raised at file "raw_backtrace.ml", line 18, characters 62-71
-Called from file "raw_backtrace.ml", line 33, characters 11-23
-Uncaught exception Raw_backtrace.Error("c")
-Raised at file "raw_backtrace.ml", line 19, characters 20-37
-Called from file "raw_backtrace.ml", line 33, characters 11-23
-Uncaught exception Raw_backtrace.Error("d")
-Raised at file "raw_backtrace.ml", line 7, characters 16-32
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 16, characters 4-11
-Called from file "raw_backtrace.ml", line 33, characters 11-23
-e
-Uncaught exception Raw_backtrace.Error("e")
-Raised at file "raw_backtrace.ml", line 7, characters 16-32
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 16, characters 4-11
-Re-raised at file "raw_backtrace.ml", line 25, characters 9-45
-Called from file "raw_backtrace.ml", line 33, characters 11-23
-f
-Uncaught exception Raw_backtrace.Localized(_)
-Raised at file "raw_backtrace.ml", line 7, characters 16-32
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 16, characters 4-11
-Re-raised at file "raw_backtrace.ml", line 29, characters 9-57
-Called from file "raw_backtrace.ml", line 33, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "raw_backtrace.ml", line 33, characters 14-22
--- /dev/null
+a
+No exception
+b
+Uncaught exception Raw_backtrace.Error("b")
+Raised at file "raw_backtrace.ml", line 16, characters 16-32
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 25, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 27, characters 62-71
+Called from file "raw_backtrace.ml", line 42, characters 11-23
+Uncaught exception Raw_backtrace.Error("c")
+Raised at file "raw_backtrace.ml", line 28, characters 20-37
+Called from file "raw_backtrace.ml", line 42, characters 11-23
+Uncaught exception Raw_backtrace.Error("d")
+Raised at file "raw_backtrace.ml", line 16, characters 16-32
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 25, characters 4-11
+Called from file "raw_backtrace.ml", line 42, characters 11-23
+e
+Uncaught exception Raw_backtrace.Error("e")
+Raised at file "raw_backtrace.ml", line 16, characters 16-32
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 25, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 34, characters 9-45
+Called from file "raw_backtrace.ml", line 42, characters 11-23
+f
+Uncaught exception Raw_backtrace.Localized(_)
+Raised at file "raw_backtrace.ml", line 16, characters 16-32
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 42-53
+Called from file "raw_backtrace.ml", line 25, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 38, characters 9-57
+Called from file "raw_backtrace.ml", line 42, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "raw_backtrace.ml", line 42, characters 14-22
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
-let compare_nan () =
- not (nan < 0.0)
+let equal (x : float) (y : float) =
+ x, "=", y, (x = y)
[@@inline never]
-let x = print_endline (string_of_bool (compare_nan ()))
+let not_equal (x : float) (y : float) =
+ x, "!=", y, (x <> y)
+[@@inline never]
+
+let less_than (x : float) (y : float) =
+ x, "<", y, (x < y)
+[@@inline never]
+
+let not_less_than (x : float) (y : float) =
+ x, "!<", y, not (x < y)
+[@@inline never]
+
+let less_equal (x : float) (y : float) =
+ x, "<=", y, (x <= y)
+[@@inline never]
+
+let not_less_equal (x : float) (y : float) =
+ x, "!<=", y, not (x <= y)
+[@@inline never]
+
+let greater_than (x : float) (y : float) =
+ x, ">", y, (x > y)
+[@@inline never]
+
+let not_greater_than (x : float) (y : float) =
+ x, "!>", y, not (x > y)
+[@@inline never]
+
+let greater_equal (x : float) (y : float) =
+ x, ">=", y, (x >= y)
+[@@inline never]
+
+let not_greater_equal (x : float) (y : float) =
+ x, "!>=", y, not (x >= y)
+[@@inline never]
+
+let show (x, op, y, b) =
+ print_float x;
+ print_string " ";
+ print_string op;
+ print_string " ";
+ print_float y;
+ print_string ": ";
+ print_endline (string_of_bool b)
+
+let print_line () =
+ print_endline "------------------"
+
+let () = show (equal 1.0 2.0)
+let () = show (equal 1.0 1.0)
+let () = show (equal 2.0 1.0)
+let () = show (equal 1.0 nan)
+let () = print_line ()
+
+let () = show (not_equal 1.0 2.0)
+let () = show (not_equal 1.0 1.0)
+let () = show (not_equal 2.0 1.0)
+let () = show (not_equal 1.0 nan)
+let () = print_line ()
+
+let () = show (less_than 1.0 2.0)
+let () = show (less_than 1.0 1.0)
+let () = show (less_than 2.0 1.0)
+let () = show (less_than 1.0 nan)
+let () = print_line ()
+
+let () = show (not_less_than 1.0 2.0)
+let () = show (not_less_than 1.0 1.0)
+let () = show (not_less_than 2.0 1.0)
+let () = show (not_less_than 1.0 nan)
+let () = print_line ()
+
+let () = show (less_equal 1.0 2.0)
+let () = show (less_equal 1.0 1.0)
+let () = show (less_equal 2.0 1.0)
+let () = show (less_equal 1.0 nan)
+let () = print_line ()
+
+let () = show (not_less_equal 1.0 2.0)
+let () = show (not_less_equal 1.0 1.0)
+let () = show (not_less_equal 2.0 1.0)
+let () = show (not_less_equal 1.0 nan)
+let () = print_line ()
+
+let () = show (greater_than 1.0 2.0)
+let () = show (greater_than 1.0 1.0)
+let () = show (greater_than 2.0 1.0)
+let () = show (greater_than 1.0 nan)
+let () = print_line ()
+
+let () = show (not_greater_than 1.0 2.0)
+let () = show (not_greater_than 1.0 1.0)
+let () = show (not_greater_than 2.0 1.0)
+let () = show (not_greater_than 1.0 nan)
+let () = print_line ()
+
+let () = show (greater_equal 1.0 2.0)
+let () = show (greater_equal 1.0 1.0)
+let () = show (greater_equal 2.0 1.0)
+let () = show (greater_equal 1.0 nan)
+let () = print_line ()
+
+let () = show (not_greater_equal 1.0 2.0)
+let () = show (not_greater_equal 1.0 1.0)
+let () = show (not_greater_equal 2.0 1.0)
+let () = show (not_greater_equal 1.0 nan)
+let () = print_line ()
-true
+1. = 2.: false
+1. = 1.: true
+2. = 1.: false
+1. = nan: false
+------------------
+1. != 2.: true
+1. != 1.: false
+2. != 1.: true
+1. != nan: true
+------------------
+1. < 2.: true
+1. < 1.: false
+2. < 1.: false
+1. < nan: false
+------------------
+1. !< 2.: false
+1. !< 1.: true
+2. !< 1.: true
+1. !< nan: true
+------------------
+1. <= 2.: true
+1. <= 1.: true
+2. <= 1.: false
+1. <= nan: false
+------------------
+1. !<= 2.: false
+1. !<= 1.: false
+2. !<= 1.: true
+1. !<= nan: true
+------------------
+1. > 2.: false
+1. > 1.: false
+2. > 1.: true
+1. > nan: false
+------------------
+1. !> 2.: true
+1. !> 1.: true
+2. !> 1.: false
+1. !> nan: true
+------------------
+1. >= 2.: false
+1. >= 1.: true
+2. >= 1.: true
+1. >= nan: false
+------------------
+1. !>= 2.: true
+1. !>= 1.: false
+2. !>= 1.: false
+1. !>= nan: true
+------------------
--- /dev/null
+tfloat_hex.ml
+tfloat_record.ml
+zero_sized_float_arrays.ml
+(* TEST *)
+
let try_float_of_string str =
try
print_float (float_of_string str);
try_float_of_string "0x.";
try_float_of_string "0xp0";
try_float_of_string "0x.p0";
+
+ (* MPR#7690 *)
+ try_float_of_string "0x1.0p-2147483648";
+ try_float_of_string "0x123456789ABCDEF0p2147483647";
+ try_float_of_string "0x1p2147483648";
Failure("float_of_string")
Failure("float_of_string")
Failure("float_of_string")
+0.
+inf
+inf
+(* TEST *)
+
module Float_record : sig
type t = private float;;
+(* TEST *)
+
let non_float_array : int array = [| |]
let float_array : float array = [| |]
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-#MODULES=
-MAIN_MODULE=manyargs
-C_FILES=manyargsprim
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ modules = "manyargsprim.c"
+*)
+
let manyargs a b c d e f g h i j k l m n o =
print_string "a = "; print_int a; print_newline();
print_string "b = "; print_int b; print_newline();
--- /dev/null
+manyargs.ml
main.ml
+recursive_module_evaluation_errors.ml
--- /dev/null
+(* TEST
+ * expect
+*)
+
+module rec A: sig val x: int end = struct let x = B.x end
+and B:sig val x: int end = struct let x = E.y end
+and C:sig val x: int end = struct let x = B.x end
+and D:sig val x: int end = struct let x = C.x end
+and E:sig val x: int val y:int end = struct let x = D.x let y = 0 end
+[%%expect {|
+Line _, characters 27-49:
+ and B:sig val x: int end = struct let x = E.y end
+ ^^^^^^^^^^^^^^^^^^^^^^
+Error: Cannot safely evaluate the definition of the following cycle
+ of recursively-defined modules: B -> E -> D -> C -> B.
+ There are no safe modules in this cycle (see manual section 8.4)
+|}]
+
+module rec M: sig val f: unit -> int end = struct let f () = N.x end
+and N:sig val x: int end = struct let x = M.f () end;;
+[%%expect {|
+Exception: Undefined_recursive_module ("", 1, 43).
+|}]
+
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-MODULES=testing
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
-OCOPTFLAGS=-inline 20
-(* Test bound checks with ocamlopt *)
+(* TEST
+ include testing
+*)
+
+(* Test bound checks *)
let a = [| 0; 1; 2 |]
+(* TEST
+ include testing
+*)
let check f n =
assert (
+(* TEST
+ include testing
+*)
let f x = x + 1
let g x = x - 1
+(* TEST
+ include testing
+*)
let sequor b1 b2 =
let b1 = ref b1 in
--- /dev/null
+File "morematch.ml", line 1050, characters 8-65:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(A `D|B (`B, (`A|`C)))
+File "morematch.ml", line 67, characters 2-5:
+Warning 12: this sub-pattern is unused.
+File "morematch.ml", line 68, characters 2-3:
+Warning 12: this sub-pattern is unused.
+File "morematch.ml", line 219, characters 33-47:
+Warning 12: this sub-pattern is unused.
+File "morematch.ml", line 388, characters 2-15:
+Warning 11: this match case is unused.
+File "morematch.ml", line 401, characters 2-20:
+Warning 11: this match case is unused.
+File "morematch.ml", line 402, characters 2-16:
+Warning 11: this match case is unused.
+File "morematch.ml", line 403, characters 2-29:
+Warning 11: this match case is unused.
+File "morematch.ml", line 413, characters 5-12:
+Warning 12: this sub-pattern is unused.
+File "morematch.ml", line 432, characters 43-44:
+Warning 12: this sub-pattern is unused.
+File "morematch.ml", line 455, characters 7-8:
+Warning 12: this sub-pattern is unused.
+File "morematch.ml", line 456, characters 2-7:
+Warning 11: this match case is unused.
+File "morematch.ml", line 1084, characters 5-51:
+Warning 11: this match case is unused.
+File "morematch.ml", line 1086, characters 5-51:
+Warning 11: this match case is unused.
+(* TEST
+ include testing
+*)
+
(**************************************************************)
(* This suite tests the pattern-matching compiler *)
(* it should just compile and run. *)
(* While compiling the following messages are normal: *)
(**************************************************************)
-(*
-File "morematch.ml", line 38, characters 10-93:
-Warning: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-0
-File "morematch.ml", line 376, characters 2-15:
-Warning: this match case is unused.
-File "morematch.ml", line 443, characters 2-7:
-Warning: this match case is unused.
-*)
-
let test msg f arg r =
if f arg <> r then begin
prerr_endline msg ;
| 4|5|7 -> 100
| 7 | 8 -> 6
| 9 -> 7
-| _ -> 8 [@@ocaml.warning "-12"];;
+| _ -> 8
+;;
+
test "quatre" g 4 4 ;
test "quatre" g 7 100 ; ()
;;
-(*
-File "morematch.ml", line 73, characters 2-5:
-Warning U: this sub-pattern is unused.
-File "morematch.ml", line 74, characters 2-3:
-Warning U: this sub-pattern is unused.
-*)
-
let h x =
match x with
(1,1) -> 1
let f = function (([]|[_]) as x)|(_::([] as x))|(_::_::x) -> x
- [@@ocaml.warning "-12"]
;;
test "zob" f [] [] ;
| A,_,_ -> 1
| _,A,_ -> 2
| B,B,_ -> 3
-| A,_,(100|103) -> 5 [@@ocaml.warning "-11"]
+| A,_,(100|103) -> 5
;;
test "yaya" yaya (A,A,0) 1 ;
test "yaya" yaya (B,B,100) 3 ; ()
;;
-(*
+
let yoyo = function
| [],_,_ -> 1
| _,[],_ -> 2
test "youyou" youyou 101 2 ;
test "youyou" youyou 1000 3
;;
-*)
+
type autre =
| C | D | E of autre | F of autre * autre | H of autre | I | J | K of string
| (J,J,((C|D) as x |E x|F (_,x))) | (J,_,((C|J) as x)) -> autre (x,x,x)
| (J, J, (I|H _|K _)) -> 9
| I,_,_ -> 6
-| E _,_,_ -> 7 [@@ocaml.warning "-12"]
+| E _,_,_ -> 7
;;
-(*
-File "morematch.ml", line 437, characters 43-44:
-Warning U: this sub-pattern is unused.
-*)
+
+
test "autre" autre (J,J,F (D,D)) 3 ;
test "autre" autre (J,J,D) 3 ;
test "autre" autre (J,J,I) 9 ;
| YB,YB,_ -> 3
| ((YB|YC), (YB|YC), (X|Y|Z|V _|T _)) -> 6
| _,_,(X|U _) -> 8
-| _,_,Y -> 5 [@@ocaml.warning "-11-12"]
+| _,_,Y -> 5
;;
-(*
-File "morematch.ml", line 459, characters 7-8:
-Warning U: this sub-pattern is unused.
-File "morematch.ml", line 460, characters 2-7:
-Warning U: this match case is unused.
-*)
+
test "xyz" xyz (YC,YC,X) 6 ;
test "xyz" xyz (YC,YB,U X) 8 ;
test "xyz" xyz (YB,YC,X) 6 ; ()
false (in Switch)
*)
-(*
-File "morematch.ml", line 1060, characters 8-65:
-Warning: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-A `D
-*)
type ('a, 'b) t_j = A of 'a | B of 'b * 'a | C
let f = function
| A (`A|`C) -> 0
| B (`B,`D) -> 1
- | C -> 2 [@@ocaml.warning "-8"]
+ | C -> 2
let g x = try f x with Match_failure _ -> 3
| _, _, _, _, _, A, _, _, _, _, B, _, _, _, _, _ -> "11"
| B, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "12"
| _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "13"
-[@@ocaml.warning "-11"]
-(*
-File "morematch.ml", line 1094, characters 5-51:
-Warning: this match case is unused.
-File "morematch.ml", line 1096, characters 5-51:
-Warning: this match case is unused.
-*)
+
+
let _ =
test "luc" f (B, A, A, A, A, A, A, A, A, A, A, B, A, A, A, A) "10" ;
test "luc" f (B, A, A, A, A, A, A, A, A, A, A, A, A, A, A, A) "12" ;
--- /dev/null
+bounds.ml
+div_by_zero.ml
+function_in_ref.ml
+if_in_if.ml
+morematch.ml
+opaque_prim.ml
+pr1271.ml
+pr2719.ml
+pr6216.ml
+record_evaluation_order.ml
+robustmatch.ml
+sequential_and_or.ml
+structural_constants.ml
+tbuffer.ml
+testrandom.ml
+top_level_patterns.ml
+tprintf.ml
+(* TEST
+ include testing
+*)
+
let f x = Sys.opaque_identity x
let () =
+(* TEST
+ include testing
+*)
+
(* GPR#1271 *)
module F (X : sig val x : int end) = struct
+(* TEST
+ include testing
+*)
+
open Printf
let bug () =
+(* TEST
+ include testing
+ ocamlopt_flags ="-inline 20"
+*)
+
(* PR6216: wrong inlining of GADT match *)
type _ t =
+(* TEST
+ include testing
+*)
type r =
{ a : unit;
+(* TEST
+ include testing
+*)
+
let r = ref 0
let true_effect () =
+(* TEST
+ include testing
+*)
type t1 =
| A | B | C of t1 | D of float
+(* TEST
+ include testing
+*)
+
(* Dummy substitute function. *)
open Testing;;
+(* TEST
+ include testing
+*)
+
open Random
let _ =
+(* TEST
+ include testing
+*)
type t =
| A of (int * int * int)
+(* TEST
+ include testing
+*)
+
open Testing;;
open Printf;;
+++ /dev/null
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
-
-# The trigraph.ml test always fails under OpenBSD 6 / i386
-# because of an unrelated warning emitted by the linker called by ocamlopt
-# (see commit log for details).
-# As a temporary workaround, we skip this test.
-SKIP=test $$file = trigraph.ml \
- && test `uname -m` = i386 && test `uname -s` = OpenBSD
+(* TEST *)
+
let bigarray n = [|
n+0; n+1; n+2; n+3; n+4; n+5; n+6; n+7; n+8; n+9; n+10; n+11; n+12;
n+13; n+14; n+15; n+16; n+17; n+18; n+19; n+20; n+21; n+22; n+23;
+(* TEST *)
+
let _ =
match Sys.word_size with
| 32 ->
+(* TEST *)
+
(* Test the types nativeint, int32, int64 *)
open Printf
+(* TEST
+ flags = "-pp '${c_preprocessor}'"
+ * bytecode
+ compare_programs = "false"
+ * native
+*)
+
(* Test constant propagation through inlining *)
(* constprop.ml is generated from constprop.mlp using
cpp constprop.mlp > constprop.ml
*)
+
+#define tbool(x,y) \
+ (x && y, x || y, not x)
+
+#define tint(x,y,s) \
+ (-x, x + y, x - y, x * y, x / y, x mod y, \
+ x land y, x lor y, x lxor y, \
+ x lsl s, x lsr s, x asr s, \
+ x = y, x <> y, x < y, x <= y, x > y, x >= y, \
+ succ x, pred y)
+
+#define tfloat(x,y) \
+ (int_of_float x, \
+ x +. y, x -. y, x *. y, x /. y, \
+ x = y, x <> y, x < y, x <= y, x > y, x >= y)
+
+#define tconvint(i) \
+ (float_of_int i, \
+ Int32.of_int i, \
+ Nativeint.of_int i, \
+ Int64.of_int i)
+
+#define tconvint32(i) \
+ (Int32.to_int i, \
+ Nativeint.of_int32 i, \
+ Int64.of_int32 i)
+
+#define tconvnativeint(i) \
+ (Nativeint.to_int i, \
+ Nativeint.to_int32 i, \
+ Int64.of_nativeint i)
+
+#define tconvint64(i) \
+ (Int64.to_int i, \
+ Int64.to_int32 i, \
+ Int64.to_nativeint i) \
+
+#define tint32(x,y,s) \
+ Int32.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \
+ logand x y, logor x y, logxor x y, \
+ shift_left x s, shift_right x s, shift_right_logical x s, \
+ x = y, x <> y, x < y, x <= y, x > y, x >= y)
+
+#define tnativeint(x,y,s) \
+ Nativeint.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \
+ logand x y, logor x y, logxor x y, \
+ shift_left x s, shift_right x s, shift_right_logical x s, \
+ x = y, x <> y, x < y, x <= y, x > y, x >= y)
+
+#define tint64(x,y,s) \
+ Int64.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \
+ logand x y, logor x y, logxor x y, \
+ shift_left x s, shift_right x s, shift_right_logical x s, \
+ x = y, x <> y, x < y, x <= y, x > y, x >= y)
+
let do_test msg res1 res2 =
Printf.printf "%s: %s\n" msg (if res1 = res2 then "passed" else "FAILED")
+
(* Hide a constant from the optimizer, preventing constant propagation *)
let hide x = List.nth [x] 0
+
let _ =
begin
let x = true and y = false in
let xh = hide x and yh = hide y in
- do_test "booleans" ((x && y, x || y, not x)) ((xh && yh, xh || yh, not xh))
+ do_test "booleans" (tbool(x, y)) (tbool(xh,yh))
end;
begin
let x = 89809344 and y = 457455773 and s = 7 in
let xh = hide x and yh = hide y and sh = hide s in
- do_test "integers"
- ((-x, x + y, x - y, x * y, x / y, x mod y, x land y,
- x lor y, x lxor y, x lsl s, x lsr s, x asr s, x = y,
- x <> y, x < y, x <= y, x > y, x >= y, succ x, pred y))
- ((-xh, xh + yh, xh - yh, xh * yh, xh / yh, xh mod yh, xh land yh,
- xh lor yh, xh lxor yh, xh lsl sh, xh lsr sh, xh asr sh, xh = yh,
- xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh, succ xh, pred yh))
+ do_test "integers" (tint(x, y, s)) (tint(xh,yh,sh))
end;
begin
let x = 3.141592654 and y = 0.341638588598232096 in
let xh = hide x and yh = hide y in
- do_test "floats"
- ((int_of_float x, x +. y, x -. y, x *. y, x /. y, x = y,
- x <> y, x < y, x <= y, x > y, x >= y))
- ((int_of_float xh, xh +. yh, xh -. yh, xh *. yh, xh /. yh, xh = yh,
- xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh))
+ do_test "floats" (tfloat(x, y)) (tfloat(xh, yh))
end;
begin
let x = 781944104l and y = 308219921l and s = 3 in
let xh = hide x and yh = hide y and sh = hide s in
- do_test "32-bit integers"
- (Int32.(neg x, add x y, sub x y, mul x y, div x y, rem x y,
- logand x y, logor x y, logxor x y, shift_left x s,
- shift_right x s, shift_right_logical x s, x = y, x <> y,
- x < y, x <= y, x > y, x >= y))
- (Int32.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh,
- logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh,
- shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh,
- xh < yh, xh <= yh, xh > yh, xh >= yh))
+ do_test "32-bit integers" (tint32(x, y, s)) (tint32(xh, yh, sh))
end;
begin
let x = 1828697041n and y = -521695949n and s = 8 in
let xh = hide x and yh = hide y and sh = hide s in
- do_test "native integers"
- (Nativeint.(neg x, add x y, sub x y, mul x y, div x y,
- rem x y, logand x y, logor x y, logxor x y,
- shift_left x s, shift_right x s,
- shift_right_logical x s, x = y, x <> y, x < y,
- x <= y, x > y, x >= y))
- (Nativeint.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh,
- rem xh yh, logand xh yh, logor xh yh, logxor xh yh,
- shift_left xh sh, shift_right xh sh,
- shift_right_logical xh sh, xh = yh, xh <> yh, xh < yh,
- xh <= yh, xh > yh, xh >= yh))
+ do_test "native integers" (tnativeint(x, y, s)) (tnativeint(xh, yh, sh))
end;
begin
let x = 1511491586921138079L and y = 6677538715441746158L and s = 17 in
let xh = hide x and yh = hide y and sh = hide s in
- do_test "64-bit integers"
- (Int64.(neg x, add x y, sub x y, mul x y, div x y, rem x y,
- logand x y, logor x y, logxor x y, shift_left x s,
- shift_right x s, shift_right_logical x s, x = y, x <> y,
- x < y, x <= y, x > y, x >= y))
- (Int64.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh,
- logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh,
- shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh,
- xh < yh, xh <= yh, xh > yh, xh >= yh))
+ do_test "64-bit integers" (tint64(x, y, s)) (tint64(xh, yh, sh))
end;
begin
let x = 1000807289 in
let xh = hide x in
- do_test "integer conversions"
- ((float_of_int x, Int32.of_int x, Nativeint.of_int x, Int64.of_int x))
- ((float_of_int xh, Int32.of_int xh, Nativeint.of_int xh, Int64.of_int xh))
+ do_test "integer conversions" (tconvint(x)) (tconvint(xh))
end;
begin
let x = 10486393l in
let xh = hide x in
- do_test "32-bit integer conversions"
- ((Int32.to_int x, Nativeint.of_int32 x, Int64.of_int32 x))
- ((Int32.to_int xh, Nativeint.of_int32 xh, Int64.of_int32 xh))
+ do_test "32-bit integer conversions" (tconvint32(x)) (tconvint32(xh))
end;
begin
let x = -131134014n in
let xh = hide x in
- do_test "native integer conversions"
- ((Nativeint.to_int x, Nativeint.to_int32 x, Int64.of_nativeint x))
- ((Nativeint.to_int xh, Nativeint.to_int32 xh, Int64.of_nativeint xh))
+ do_test "native integer conversions" (tconvnativeint(x))(tconvnativeint(xh))
end;
begin
let x = 531871273453404175L in
let xh = hide x in
- do_test "64-bit integer conversions"
- ((Int64.to_int x, Int64.to_int32 x, Int64.to_nativeint x))
- ((Int64.to_int xh, Int64.to_int32 xh, Int64.to_nativeint xh))
+ do_test "64-bit integer conversions" (tconvint64(x)) (tconvint64(xh))
end
+++ /dev/null
-(* Test constant propagation through inlining *)
-
-(* constprop.ml is generated from constprop.mlp using
- cpp constprop.mlp > constprop.ml
-*)
-
-#define tbool(x,y) \
- (x && y, x || y, not x)
-
-#define tint(x,y,s) \
- (-x, x + y, x - y, x * y, x / y, x mod y, \
- x land y, x lor y, x lxor y, \
- x lsl s, x lsr s, x asr s, \
- x = y, x <> y, x < y, x <= y, x > y, x >= y, \
- succ x, pred y)
-
-#define tfloat(x,y) \
- (int_of_float x, \
- x +. y, x -. y, x *. y, x /. y, \
- x = y, x <> y, x < y, x <= y, x > y, x >= y)
-
-#define tconvint(i) \
- (float_of_int i, \
- Int32.of_int i, \
- Nativeint.of_int i, \
- Int64.of_int i)
-
-#define tconvint32(i) \
- (Int32.to_int i, \
- Nativeint.of_int32 i, \
- Int64.of_int32 i)
-
-#define tconvnativeint(i) \
- (Nativeint.to_int i, \
- Nativeint.to_int32 i, \
- Int64.of_nativeint i)
-
-#define tconvint64(i) \
- (Int64.to_int i, \
- Int64.to_int32 i, \
- Int64.to_nativeint i) \
-
-#define tint32(x,y,s) \
- Int32.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \
- logand x y, logor x y, logxor x y, \
- shift_left x s, shift_right x s, shift_right_logical x s, \
- x = y, x <> y, x < y, x <= y, x > y, x >= y)
-
-#define tnativeint(x,y,s) \
- Nativeint.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \
- logand x y, logor x y, logxor x y, \
- shift_left x s, shift_right x s, shift_right_logical x s, \
- x = y, x <> y, x < y, x <= y, x > y, x >= y)
-
-#define tint64(x,y,s) \
- Int64.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \
- logand x y, logor x y, logxor x y, \
- shift_left x s, shift_right x s, shift_right_logical x s, \
- x = y, x <> y, x < y, x <= y, x > y, x >= y)
-
-let do_test msg res1 res2 =
- Printf.printf "%s: %s\n" msg (if res1 = res2 then "passed" else "FAILED")
-
-(* Hide a constant from the optimizer, preventing constant propagation *)
-let hide x = List.nth [x] 0
-
-let _ =
- begin
- let x = true and y = false in
- let xh = hide x and yh = hide y in
- do_test "booleans" (tbool(x, y)) (tbool(xh,yh))
- end;
- begin
- let x = 89809344 and y = 457455773 and s = 7 in
- let xh = hide x and yh = hide y and sh = hide s in
- do_test "integers" (tint(x, y, s)) (tint(xh,yh,sh))
- end;
- begin
- let x = 3.141592654 and y = 0.341638588598232096 in
- let xh = hide x and yh = hide y in
- do_test "floats" (tfloat(x, y)) (tfloat(xh, yh))
- end;
- begin
- let x = 781944104l and y = 308219921l and s = 3 in
- let xh = hide x and yh = hide y and sh = hide s in
- do_test "32-bit integers" (tint32(x, y, s)) (tint32(xh, yh, sh))
- end;
- begin
- let x = 1828697041n and y = -521695949n and s = 8 in
- let xh = hide x and yh = hide y and sh = hide s in
- do_test "native integers" (tnativeint(x, y, s)) (tnativeint(xh, yh, sh))
- end;
- begin
- let x = 1511491586921138079L and y = 6677538715441746158L and s = 17 in
- let xh = hide x and yh = hide y and sh = hide s in
- do_test "64-bit integers" (tint64(x, y, s)) (tint64(xh, yh, sh))
- end;
- begin
- let x = 1000807289 in
- let xh = hide x in
- do_test "integer conversions" (tconvint(x)) (tconvint(xh))
- end;
- begin
- let x = 10486393l in
- let xh = hide x in
- do_test "32-bit integer conversions" (tconvint32(x)) (tconvint32(xh))
- end;
- begin
- let x = -131134014n in
- let xh = hide x in
- do_test "native integer conversions" (tconvnativeint(x))(tconvnativeint(xh))
- end;
- begin
- let x = 531871273453404175L in
- let xh = hide x in
- do_test "64-bit integer conversions" (tconvint64(x)) (tconvint64(xh))
- end
+(* TEST *)
+
open Printf
(* Test integer division and modulus, esp. ocamlopt's optimization
+(* TEST *)
+
let test n check res =
print_string "Test "; print_int n;
if check res then print_string " passed.\n" else print_string " FAILED.\n";
+(* TEST *)
+
let f x y = Printf.printf "%d %d\n" x y
let i = ref 0
+(* TEST *)
+
(* PR#6136 *)
exception Ok
+(* TEST *)
+
let i = ref 0
let f x y =
+(* TEST *)
+
(* PR#7531 *)
let f =
+(* TEST *)
+
type t =
{ mutable x : int;
y : int }
+(* TEST *)
+
Printf.printf "1./.0. = %f\n" (1.0 /. 0.0);;
+(* TEST *)
+
let a = -0.
let b = +0.
+(* TEST *)
+
(* Test for "include <module-expr>" inside structures *)
module A =
+(* TEST *)
+
let f (type t) () =
let exception E of t in
(fun x -> E x), (function E _ -> print_endline "OK" | _ -> print_endline "KO")
+(* TEST *)
+
module IntMap = Map.Make(struct type t = int let compare x y = x-y end)
let m1 = IntMap.add 0 "A" (IntMap.add 4 "Y" (IntMap.singleton 3 "X1"))
+(* TEST *)
+
(* This will test the parsing of the smallest integer on 32-bit architectures.
It doesn't do much on 64-bit but at least it doesn't crash.
*)
--- /dev/null
+arrays.ml
+bigints.ml
+boxedints.ml
+constprop.ml
+divint.ml
+equality.ml
+eval_order_1.ml
+eval_order_2.ml
+eval_order_3.ml
+eval_order_4.ml
+eval_order_6.ml
+float.ml
+float_physical_equality.ml
+includestruct.ml
+localexn.ml
+maps.ml
+min_int.ml
+opt_variants.ml
+patmatch.ml
+pr7253.ml
+pr7533.ml
+pr7657.ml
+recvalues.ml
+sets.ml
+stringmatch.ml
+switch_opts.ml
+tailcalls.ml
+trigraph.ml
+zero_divided_by_n.ml
+(* TEST *)
+
let () =
assert(Sys.getenv_opt "FOOBAR_UNLIKELY_TO_EXIST_42" = None);
+(* TEST *)
+
(* Tests for matchings on integers and characters *)
(* Dense integer switch *)
--- /dev/null
+(* TEST *)
+
+(* MPR#7253: "at_exit functions get called twice if a callback raises
+ and prevents earlier handlers to execute." *)
+
+exception My_exception
+
+let () =
+ Printexc.set_uncaught_exception_handler (fun exn bt ->
+ match exn with
+ | My_exception -> print_endline "Caught"; exit 0
+ | _ -> print_endline "Unexpected uncaught exception");
+ at_exit (fun () -> print_endline "Last");
+ at_exit (fun () -> print_endline "Raise"; raise My_exception);
+ at_exit (fun () -> print_endline "First")
+
--- /dev/null
+First
+Raise
+Last
+Caught
+(* TEST *)
+
(* PR#7533 *)
exception Foo
+(* TEST *)
+
[@@@ocaml.warning "-21-5"]
let foo g () = g 1; ()
+(* TEST *)
+
(* Recursive value definitions *)
let _ =
+(* TEST *)
+
module IntSet = Set.Make(struct type t = int let compare x y = x-y end)
let even = List.fold_right IntSet.add [0; -2; 2; 4; 6; -10] IntSet.empty
+(* TEST *)
+
(* Empty string oddities *)
let rec tst01 s = match s with
+(* TEST *)
+
(* Test for optimisation of jump tables to arrays of constants *)
let p = Printf.printf
+(* TEST *)
+
let rec tailcall4 a b c d =
if a < 0
then b
+(* TEST *)
+
(* PR#6373 *)
let () = print_string "??'"
+(* TEST *)
+
(* Mantis 7201 *)
let f () = 0 [@@inline never]
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-
-COMPFLAGS=-I $(OTOPDIR)/otherlibs/unix
-LD_PATH=$(TOPDIR)/otherlibs/unix
-
-.PHONY: default
-default:
- @case " $(OTHERLIBRARIES) " in \
- *' unix '*) $(SET_LD_PATH) $(MAKE) run-byte; \
- $(SET_LD_PATH) $(MAKE) run-opt;; \
- *) $(MAKE) skip;; \
- esac
-
-.PHONY: common
-common:
- @$(CC) -c $(CFLAGS) $(CPPFLAGS) -I$(CTOPDIR)/byterun callbackprim.c
-
-.PHONY: skip
-skip:
- @for c in bytecode native; do \
- echo " ... testing '$$c': => skipped" ; \
- done
-
-.PHONY: run-byte
-run-byte: common
- @printf " ... testing 'bytecode':"
- @$(OCAMLC) $(COMPFLAGS) -c tcallback.ml
- @$(OCAMLC) $(COMPFLAGS) -o ./program$(EXE) -custom unix.cma \
- callbackprim.$(O) tcallback.cmo
- @./program$(EXE) >bytecode.result
- @$(DIFF) reference bytecode.result \
- && echo " => passed" || echo " => failed"
-
-.PHONY: run-opt
-run-opt: common
- @if $(BYTECODE_ONLY); then : ; else \
- printf " ... testing 'native':"; \
- $(OCAMLOPT) $(COMPFLAGS) -c tcallback.ml; \
- $(OCAMLOPT) $(COMPFLAGS) -o ./program$(EXE) unix.cmxa \
- callbackprim.$(O) tcallback.cmx; \
- ./program$(EXE) >native.result; \
- $(DIFF) reference native.result \
- && echo " => passed" || echo " => failed"; \
- fi
-
-.PHONY: promote
-promote: defaultpromote
-
-.PHONY: clean
-clean: defaultclean
- @rm -f *.result ./program$(EXE)
-
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+tcallback.ml
+++ /dev/null
-7
-7
-7
-7
-7
-aaaaa
-aaaaa
-bbbbb
+(* TEST
+ include unix
+ modules = "callbackprim.c"
+ * libunix
+ ** bytecode
+ ** native
+*)
+
(**************************************************************************)
external mycallback1 : ('a -> 'b) -> 'a -> 'b = "mycallback1"
--- /dev/null
+7
+7
+7
+7
+7
+aaaaa
+aaaaa
+bbbbb
+++ /dev/null
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.dparsetree
-include $(BASEDIR)/makefiles/Makefile.common
+++ /dev/null
-type t = Label (**)
-(** attached to t *)
-
-(**)
-
-(** Empty docstring comments should not generate attributes *)
-
-type w (**)
+++ /dev/null
-[
- structure_item (empty.ml[1,0+0]..[1,0+14])
- Pstr_type Rec
- [
- type_declaration "t" (empty.ml[1,0+5]..[1,0+6]) (empty.ml[1,0+0]..[1,0+14])
- attribute "ocaml.doc"
- [
- structure_item (empty.ml[2,20+0]..[2,20+20])
- Pstr_eval
- expression (empty.ml[2,20+0]..[2,20+20])
- Pexp_constant PConst_string(" attached to t ",None)
- ]
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_variant
- [
- (empty.ml[1,0+9]..[1,0+14])
- "Label" (empty.ml[1,0+9]..[1,0+14])
- []
- None
- ]
- ptype_private = Public
- ptype_manifest =
- None
- ]
- structure_item (empty.ml[6,48+0]..[6,48+62])
- Pstr_attribute "ocaml.text"
- [
- structure_item (empty.ml[6,48+0]..[6,48+62])
- Pstr_eval
- expression (empty.ml[6,48+0]..[6,48+62])
- Pexp_constant PConst_string(" Empty docstring comments should not generate attributes ",None)
- ]
- structure_item (empty.ml[8,112+0]..[8,112+6])
- Pstr_type Rec
- [
- type_declaration "w" (empty.ml[8,112+5]..[8,112+6]) (empty.ml[8,112+0]..[8,112+6])
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_abstract
- ptype_private = Public
- ptype_manifest =
- None
- ]
-]
-
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-
-.PHONY: default
-default:
- @$(MAKE) compile
- @$(MAKE) run
-
-.PHONY: compile
-compile:
- @$(OCAMLC) -ccopt -I -ccopt $(CTOPDIR)/byterun cmstub.c
- @$(OCAMLC) -ccopt -I -ccopt $(CTOPDIR)/byterun cmmain.c
- @$(OCAMLC) -c cmcaml.ml
- @$(OCAMLC) -custom -o program cmstub.$(O) cmcaml.cmo cmmain.$(O)
-
-.PHONY: run
-run:
- @printf " ... testing 'cmmain':"
- @./program >program.result
- @$(DIFF) program.reference program.result >/dev/null \
- && echo " => passed" || echo " => failed"
-
-.PHONY: promote
-promote: defaultpromote
-
-.PHONY: clean
-clean: defaultclean
- @rm -f *.result program
-
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ modules = "cmstub.c cmmain.c"
+*)
+
(* OCaml part of the code *)
let rec fib n =
--- /dev/null
+Initializing OCaml code...
+Back in C code...
+Computing fib(20)...
+Result = 10946
+++ /dev/null
-Initializing OCaml code...
-Back in C code...
-Computing fib(20)...
-Result = 10946
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Damien Doligez, projet Gallium, INRIA Rocquencourt *
-#* *
-#* Copyright 2013 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-MAIN_MODULE=exotic
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
(* Exotic OCaml syntax constructs found in the manual that are not *)
(* used in the source of the OCaml distribution (even in the tests). *)
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
type t = ..
module M = struct
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-
-ADD_OPTFLAGS=-unbox-closures
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+(* TEST
+ * flambda
+ * native
+*)
+
+(* from GPR#1794 *)
+
+let z =
+ let x = -0. and y = +0. in
+ if mod_float x 1. >= 0. then
+ x
+ else if false then x else y
+
+let () =
+ Printf.printf "%g\n" (1. /. z)
+(* TEST
+ ocamlopt_flags = "-unbox-closures"
+*)
+
(* This test attempts to check that unused closures are not deleted
during conversion from flambda to clambda. The idea is that there is
a direct call to [foo] in [bar] even though the closure for [foo] is
--- /dev/null
+approx_meet.ml
+gpr998.ml
+specialise.ml
--- /dev/null
+(* TEST
+ * flambda
+ ** native
+ ocamlopt_flags = "-O2 -inline-call-cost 1=20 -unbox-closures"
+*)
+
+let hide_until_round_2 init_in_hide f_in_hide =
+ let x1_in_hide =
+ match init_in_hide with
+ | 0 -> true
+ | _ -> false
+ in
+ ignore (Sys.opaque_identity x1_in_hide);
+ let x2_in_hide =
+ match init_in_hide with
+ | 0 -> true
+ | _ -> false
+ in
+ ignore (Sys.opaque_identity x2_in_hide);
+ f_in_hide
+
+let foo bar init a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 =
+ let f_outer =
+ let baz = bar + 1 in
+ let rec f_inner x_in_f y_in_f b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 =
+ let dec =
+ b1 + b2 + b3 + b4 + b5 + b6 + b7 + b8 + b9 + b10 + b11 + b12 + b13
+ in
+ match x_in_f with
+ | Some _ -> g_inner x_in_f (y_in_f - dec)
+ | None -> g_inner x_in_f (y_in_f - 2)
+ and g_inner x_in_g y_in_g =
+ let a1 = baz + 1 in
+ let a2 = a1 + 1 in
+ let a3 = a2 + 1 in
+ let a4 = a3 + 1 in
+ let a5 = a4 + 1 in
+ let a6 = a5 + 1 in
+ let a7 = a6 + 1 in
+ let a8 = a7 + 1 in
+ let a9 = a8 + 1 in
+ let a10 = a9 + 1 in
+ let a11 = a10 + 1 in
+ let a12 = a11 + 1 in
+ let a13 = a12 + 1 in
+ match x_in_g with
+ | Some _ -> f_inner x_in_g (y_in_g - baz) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13
+ | None -> f_inner x_in_g (y_in_g - baz) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13
+ in
+ f_inner
+ in
+ let s = Some init in
+ let f_through_hide = hide_until_round_2 init f_outer in
+ (f_through_hide [@specialised]) s 10 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13
+++ /dev/null
-#(***********************************************************************)
-#(* *)
-#(* OCaml *)
-#(* *)
-#(* Mark Shinwell, Jane Street Europe *)
-#(* *)
-#(* Copyright 2014 Institut National de Recherche en Informatique et *)
-#(* en Automatique. All rights reserved. This file is distributed *)
-#(* under the terms of the Q Public License version 1.0. *)
-#(* *)
-#(***********************************************************************)
-
-BASEDIR=../..
-MODULES=float_inline
-MAIN_MODULE=float_subst_boxed_number
-ADD_OPTCOMPFLAGS=-inline 20
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
-
-GENERATED_SOURCES=float_inline.ml *.flambda
-
-float_inline.ml: $(FLAMBDA).flambda
-ifeq ($(FLAMBDA),false)
- @echo "let eliminate_intermediate_float_record () = ()" > $@
-else
- @cat float_flambda.ml > $@
-endif
-
-%.flambda:
- @rm -f float_inline.ml
- @touch $@
+++ /dev/null
-let eliminate_intermediate_float_record () =
- let r = ref 0. in
- for n = 1 to 1000 do
- let open Complex in
- let c = { re = float n; im = 0. } in
- r := !r +. (norm [@inlined]) ((add [@inlined]) c i);
- done;
- ignore (Sys.opaque_identity !r)
-
+(* TEST
+ include config
+ flags = "-w -55"
+ ocamlc_flags = "config.cmo"
+ ocamlopt_flags = "-inline 20 config.cmx"
+*)
+
+let eliminate_intermediate_float_record () =
+ let r = ref 0. in
+ for n = 1 to 1000 do
+ let open Complex in
+ let c = { re = float n; im = 0. } in
+ (* The following line triggers warning 55 twice when compiled without flambda *)
+ (* It would be better to disable this warning just here but since *)
+ (* this is a backend-warning, this is not currently possible *)
+ (* Hence the use of the -w-55 command-line flag for this test *)
+ r := !r +. (norm [@inlined]) ((add [@inlined]) c i);
+ done;
+ ignore (Sys.opaque_identity !r)
+
module PR_6686 = struct
type t =
| A of float
let a2 = Gc.allocated_bytes () in
let alloc = (a2 -. 2. *. a1 +. a0) in
- (* is there a better to test whether we run in native code? *)
- match Filename.basename Sys.argv.(0) with
- | "program.byte" | "program.byte.exe" -> ()
- | "program.native" | "program.native.exe" ->
+ match Sys.backend_type with
+ | Sys.Bytecode -> ()
+ | Sys.Native ->
if alloc > 100. then
failwith (Printf.sprintf "%s; alloc = %.0f" name alloc)
| _ -> assert false
ignore (g 0 10 5.)
let () =
- let flambda =
- match Sys.getenv "FLAMBDA" with
- | "true" -> true
- | "false" -> false
- | _ -> failwith "Cannot determine is flambda is enabled"
- | exception Not_found -> failwith "Cannot determine is flambda is enabled"
- in
-
check_noalloc "classify float" unbox_classify_float;
check_noalloc "compare float" unbox_compare_float;
check_noalloc "float refs" unbox_float_refs;
check_noalloc "unbox only if useful" unbox_only_if_useful;
check_noalloc "ignore useless args" ignore_useless_args;
- if flambda then begin
+ if Config.flambda then begin
check_noalloc "float and int32 record" unbox_record;
check_noalloc "eliminate intermediate immutable float record"
- Float_inline.eliminate_intermediate_float_record;
+ eliminate_intermediate_float_record;
end;
check_noalloc "Gc.minor_words" unbox_minor_words;
--- /dev/null
+float_subst_boxed_number.ml
+++ /dev/null
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * toplevel
+*)
+
(* %n, %l, %N and %L have a scanf-specific semantics, but are supposed
to be interpreted by Printf and Format as %u, despite this
interpretation being mildly deprecated *)
+++ /dev/null
-
-# * * val test : (int -> string, unit, string) format -> string = <fun>
-# %n: true
-# %l: true
-# %N: true
-# %L: true
-#
--- /dev/null
+val test : (int -> string, unit, string) format -> string = <fun>
+%n: true
+%l: true
+%N: true
+%L: true
+
+(* TEST
+ * toplevel
+*)
+
(* Benoit's patch did not support %_[nlNL]; test their behavior *)
(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+++ /dev/null
-
-# - : unit = ()
-# Exception: Invalid_argument "Printf: bad conversion %_".
-# Exception: Invalid_argument "Printf: bad conversion %_".
-# Exception: Invalid_argument "Printf: bad conversion %_".
-# Exception: Invalid_argument "Printf: bad conversion %_".
-# Exception: Invalid_argument "Printf: bad conversion %_".
-# Exception: Invalid_argument "Printf: bad conversion %_".
-# Exception: Invalid_argument "Printf: bad conversion %_".
-# Exception: Invalid_argument "Printf: bad conversion %_".
-# Hello World!
-# Hello World!
-# Hello World!
-# Hello World!
-#
--- /dev/null
+- : unit = ()
+Exception: Invalid_argument "Printf: bad conversion %_".
+Exception: Invalid_argument "Printf: bad conversion %_".
+Exception: Invalid_argument "Printf: bad conversion %_".
+Exception: Invalid_argument "Printf: bad conversion %_".
+Exception: Invalid_argument "Printf: bad conversion %_".
+Exception: Invalid_argument "Printf: bad conversion %_".
+Exception: Invalid_argument "Printf: bad conversion %_".
+Exception: Invalid_argument "Printf: bad conversion %_".
+Hello World!
+Hello World!
+Hello World!
+Hello World!
+
+(* TEST
+ * toplevel
+*)
+
(* the legacy parser ignores flags on formatters on which they make no
sense *)
+++ /dev/null
-
-# * toto
-# toto
-# toto
-# toto
-# "toto"
-# toto
-# * * *
--- /dev/null
+toto
+toto
+toto
+toto
+"toto"
+toto
+
+(* TEST
+ * toplevel
+*)
+
(* test whether padding modifiers are accepted without any padding
size
+++ /dev/null
-
-# * * * * * * * * 3
-# 3
-# 3
-# 3
-#
--- /dev/null
+3
+3
+3
+3
+
--- /dev/null
+deprecated_unsigned_printers.ml
+ignored_scan_counters.ml
+legacy_incompatible_flags.ml
+legacy_unfinished_modifiers.ml
+++ /dev/null
-BASEDIR=../..
-MAIN_MODULE=margins
-
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * toplevel
+*)
+
let () = Format.pp_set_margin Format.std_formatter 20;;
1 + "foo";;
+++ /dev/null
-
-# # Characters 5-10:
- 1 + "foo";;
- ^^^^^
-Error: This expression has type
- string
- but an expression was expected of type
- int
-# # Characters 5-10:
- 1 + "foo";;
- ^^^^^
-Error: This expression has type string but an expression was expected of type
- int
-#
--- /dev/null
+Characters 5-10:
+ 1 + "foo";;
+ ^^^^^
+Error: This expression has type
+ string
+ but an expression was expected of type
+ int
+Characters 5-10:
+ 1 + "foo";;
+ ^^^^^
+Error: This expression has type string but an expression was expected of type
+ int
+
--- /dev/null
+margins.ml
+++ /dev/null
-BASEDIR=../..
-TOPFLAGS+=-dlambda
-include $(BASEDIR)/makefiles/Makefile.dlambda
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+(setglobal Functors!
+ (let
+ (O =
+ (module-defn(O) functors.ml(12):184-279
+ (function X is_a_functor always_inline
+ (let
+ (cow = (function x (apply (field 0 X) x))
+ sheep = (function x (+ 1 (apply cow x))))
+ (makeblock 0 cow sheep))))
+ F =
+ (module-defn(F) functors.ml(17):281-392
+ (function X Y is_a_functor always_inline
+ (let
+ (cow = (function x (apply (field 0 Y) (apply (field 0 X) x)))
+ sheep = (function x (+ 1 (apply cow x))))
+ (makeblock 0 cow sheep))))
+ F1 =
+ (module-defn(F1) functors.ml(31):516-632
+ (function X Y is_a_functor always_inline
+ (let
+ (cow = (function x (apply (field 0 Y) (apply (field 0 X) x)))
+ sheep = (function x (+ 1 (apply cow x))))
+ (makeblock 0 sheep))))
+ F2 =
+ (module-defn(F2) functors.ml(36):634-784
+ (function X Y is_a_functor always_inline
+ (let
+ (X =a (makeblock 0 (field 1 X))
+ Y =a (makeblock 0 (field 1 Y))
+ cow = (function x (apply (field 0 Y) (apply (field 0 X) x)))
+ sheep = (function x (+ 1 (apply cow x))))
+ (makeblock 0 sheep))))
+ M =
+ (module-defn(M) functors.ml(41):786-970
+ (let
+ (F =
+ (module-defn(F) functors.ml(44):849-966
+ (function X Y is_a_functor always_inline
+ (let
+ (cow =
+ (function x (apply (field 0 Y) (apply (field 0 X) x)))
+ sheep = (function x (+ 1 (apply cow x))))
+ (makeblock 0 cow sheep)))))
+ (makeblock 0
+ (function funarg funarg is_a_functor stub
+ (let
+ (let =
+ (apply F (makeblock 0 (field 1 funarg))
+ (makeblock 0 (field 1 funarg))))
+ (makeblock 0 (field 1 let))))))))
+ (makeblock 0 O F F1 F2 M)))
+(* TEST
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ flags = "-dlambda -dno-unique-ids"
+ *** check-ocamlc.byte-output
+*)
+
module type S = sig
val foo : int -> int
end
+++ /dev/null
-(setglobal Functors!
- (let
- (O =
- (module-defn(O) functors.ml(5):48-143
- (function X is_a_functor always_inline
- (let
- (cow = (function x (apply (field 0 X) x))
- sheep = (function x (+ 1 (apply cow x))))
- (makeblock 0 cow sheep))))
- F =
- (module-defn(F) functors.ml(10):145-256
- (function X Y is_a_functor always_inline
- (let
- (cow =
- (function x
- (apply (field 0 Y) (apply (field 0 X) x)))
- sheep = (function x (+ 1 (apply cow x))))
- (makeblock 0 cow sheep))))
- F1/1022 =
- (module-defn(F1/1022) functors.ml(24):380-496
- (function X Y is_a_functor always_inline
- (let
- (cow =
- (function x
- (apply (field 0 Y) (apply (field 0 X) x)))
- sheep = (function x (+ 1 (apply cow x))))
- (makeblock 0 sheep))))
- F2/1029 =
- (module-defn(F2/1029) functors.ml(29):498-648
- (function X Y is_a_functor always_inline
- (let
- (X =a (makeblock 0 (field 1 X))
- Y =a (makeblock 0 (field 1 Y))
- cow =
- (function x
- (apply (field 0 Y) (apply (field 0 X) x)))
- sheep = (function x (+ 1 (apply cow x))))
- (makeblock 0 sheep))))
- M =
- (module-defn(M) functors.ml(34):650-834
- (let
- (F =
- (module-defn(F) functors.ml(37):713-830
- (function X Y is_a_functor always_inline
- (let
- (cow =
- (function x
- (apply (field 0 Y)
- (apply (field 0 X) x)))
- sheep =
- (function x (+ 1 (apply cow x))))
- (makeblock 0 cow sheep)))))
- (makeblock 0
- (function funarg funarg is_a_functor stub
- (let
- (let =
- (apply F (makeblock 0 (field 1 funarg))
- (makeblock 0 (field 1 funarg))))
- (makeblock 0 (field 1 let))))))))
- (makeblock 0 O F F1/1022 F2/1029 M)))
--- /dev/null
+functors.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-#MODULES=
-MAIN_MODULE=globroots
-C_FILES=globrootsprim
-ADD_COMPFLAGS=-w a
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ flags += " -w a "
+ modules = "globrootsprim.c"
+*)
+
module type GLOBREF = sig
type t
val register: string -> t
--- /dev/null
+globroots.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Jeremie Dimino, Jane Street Europe *
-#* *
-#* Copyright 2015 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-MODULES=
-MAIN_MODULE=test
-C_FILES=stubs
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
-
-NATIVECODE_ONLY=true
+(* TEST
+ modules = "stubs.c"
+ * native
+*)
+
external ( + ) : int64 -> int64 -> int64
= "" "test_int64_add" [@@noalloc] [@@unboxed]
external ( - ) : int64 -> int64 -> int64
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Mark Shinwell, Jane Street Europe *
-#* *
-#* Copyright 2016 Jane Street Group, LLC *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-ADD_OPTFLAGS=-O3
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ ocamlopt_flags += " -O3 "
+*)
+
(* Mantis 7301, due to A. Frisch *)
let foo () =
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * toplevel
+*)
+
let rec x = let y = () in x;;
let rec x = let module M = struct let f = x let g = x () end in fun () -> ();;
+++ /dev/null
-
-# Characters 12-27:
- let rec x = let y = () in x;;
- ^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-77:
- let rec x = let module M = struct let f = x let g = x () end in fun () -> ();;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-77:
- let rec x = let module M = struct let f = x () let g = x end in fun () -> ();;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-79:
- let rec x = (let module M = struct let f = y 0 let g = () end in fun () -> ())
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-79:
- let rec x = let module M = struct module N = struct let y = x end end in M.N.y;;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-77:
- let rec x = let module M = struct let f = x () and g = x end in fun () -> ();;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# class c : 'a -> object end
-# Characters 12-19:
- let rec x = new c x;;
- ^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-21:
- let rec x = ignore x;;
- ^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-16:
- let rec x = y 0 and y _ = ();;
- ^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-40:
- let rec c = { c with Complex.re = 1.0 };;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-38:
- let rec b = if b then true else false;;
- ^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 28-34:
- let rec x = r := x;;
- ^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-65:
- ..for i = 0 to 1 do
- let z = y in ignore z
- done
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-46:
- ..for i = 0 to y do
- ()
- done
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-47:
- ..for i = y to 10 do
- ()
- done
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-62:
- ..while false do
- let y = x in ignore y
- done
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-39:
- ..while y do
- ()
- done
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-58:
- ..while y do
- let y = x in ignore y
- done
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-16:
- let rec x = y#m and y = object method m = () end;;
- ^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-45:
- let rec x = (object method m _ = () end)#m x;;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-23:
- let rec x = y.contents and y = { contents = 3 };;
- ^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-59:
- let rec x = object val mutable v = 0 method m = v <- y end and y = 1;;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-21:
- let rec x = assert y and y = true;;
- ^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-36:
- let rec x = object method m = x end;;
- ^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-43:
- let rec x = object method m = ignore x end;;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# * Characters 230-246:
- let rec x = Pervasives.ref y
- ^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# * Characters 127-175:
- if p then (fun y -> x + g y) else (fun y -> g y)
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 37-61:
- let rec x = (module (val y : T) : T)
- ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-98:
- ..match let _ = y in raise Not_found with
- _ -> "x"
- | exception Not_found -> "z".
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-#
--- /dev/null
+Characters 38-53:
+ let rec x = let y = () in x;;
+ ^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-77:
+ let rec x = let module M = struct let f = x let g = x () end in fun () -> ();;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-77:
+ let rec x = let module M = struct let f = x () let g = x end in fun () -> ();;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-79:
+ let rec x = (let module M = struct let f = y 0 let g = () end in fun () -> ())
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-79:
+ let rec x = let module M = struct module N = struct let y = x end end in M.N.y;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-77:
+ let rec x = let module M = struct let f = x () and g = x end in fun () -> ();;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+class c : 'a -> object end
+Characters 12-19:
+ let rec x = new c x;;
+ ^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-21:
+ let rec x = ignore x;;
+ ^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-16:
+ let rec x = y 0 and y _ = ();;
+ ^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-40:
+ let rec c = { c with Complex.re = 1.0 };;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-38:
+ let rec b = if b then true else false;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 28-34:
+ let rec x = r := x;;
+ ^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 15-65:
+ ..for i = 0 to 1 do
+ let z = y in ignore z
+ done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 15-46:
+ ..for i = 0 to y do
+ ()
+ done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 15-47:
+ ..for i = y to 10 do
+ ()
+ done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 15-62:
+ ..while false do
+ let y = x in ignore y
+ done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 15-39:
+ ..while y do
+ ()
+ done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 15-58:
+ ..while y do
+ let y = x in ignore y
+ done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-16:
+ let rec x = y#m and y = object method m = () end;;
+ ^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-45:
+ let rec x = (object method m _ = () end)#m x;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-23:
+ let rec x = y.contents and y = { contents = 3 };;
+ ^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-59:
+ let rec x = object val mutable v = 0 method m = v <- y end and y = 1;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-21:
+ let rec x = assert y and y = true;;
+ ^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-36:
+ let rec x = object method m = x end;;
+ ^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 13-43:
+ let rec x = object method m = ignore x end;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 230-246:
+ let rec x = Pervasives.ref y
+ ^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 127-175:
+ if p then (fun y -> x + g y) else (fun y -> g y)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 37-61:
+ let rec x = (module (val y : T) : T)
+ ^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 15-98:
+ ..match let _ = y in raise Not_found with
+ _ -> "x"
+ | exception Not_found -> "z".
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+
+(* TEST
+ * toplevel
+*)
+
(* Example from Stephen Dolan.
Accessing an extension constructor involves accessing the module
in which it's defined.
+++ /dev/null
-
-# * * * module type T = sig exception A of int end
-# Characters 15-49:
- ..let module M = (val m) in
- M.A 42
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-#
--- /dev/null
+module type T = sig exception A of int end
+Characters 15-49:
+ ..let module M = (val m) in
+ M.A 42
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+
+++ /dev/null
-let test =
- let rec x = [| y; y |] and y = 1. in
- assert (x = [| 1.; 1. |]);
- assert (y = 1.);
- ()
-;;
+++ /dev/null
-
-# Characters 25-35:
- let rec x = [| y; y |] and y = 1. in
- ^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-#
--- /dev/null
+(* TEST
+ * no-flat-float-array
+ ** toplevel
+*)
+
+(* these recursive float arrays are allowed when -no-flat-float-array
+ is set -- the first array element is not forced on array creation
+ anymore *)
+let test =
+ let rec x = [| y; y |] and y = 1. in
+ assert (x = [| 1.; 1. |]);
+ assert (y = 1.);
+ ()
+;;
--- /dev/null
+val test : unit = ()
+
--- /dev/null
+(* TEST
+ * flat-float-array
+ ** toplevel
+*)
+
+(* when the -flat-float-array optimization is active (standard in
+ OCaml versions up to at least 4.07), creating an array inspects its
+ first element to decide whether it is a float or not; it would thus
+ be unsound to allow to recursively define a float value and an
+ array starting with that element (in general we disallow using a
+ recursively-defined value in an array literal).
+*)
+let test =
+ let rec x = [| y; y |] and y = 1. in
+ assert (x = [| 1.; 1. |]);
+ assert (y = 1.);
+ ()
+;;
--- /dev/null
+Characters 470-480:
+ let rec x = [| y; y |] and y = 1. in
+ ^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+
+(* TEST
+ * toplevel
+*)
+
(* This is not allowed because constructing the generic array 'x' involves
inspecting 'y', which is bound in the same recursive group *)
let f z = let rec x = [| y; z |] and y = z in x;;
+++ /dev/null
-
-# * Characters 162-172:
- let f z = let rec x = [| y; z |] and y = z in x;;
- ^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-#
--- /dev/null
+Characters 188-198:
+ let f z = let rec x = [| y; z |] and y = z in x;;
+ ^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+
--- /dev/null
+(* TEST
+ * toplevel
+*)
+
+let f ~x () = x ();;
+let rec x = f ~x;;
--- /dev/null
+val f : x:(unit -> 'a) -> unit -> 'a = <fun>
+Characters 12-16:
+ let rec x = f ~x;;
+ ^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+
+(* TEST
+ * toplevel
+*)
+
let rec a = lazy b and b = 3;;
let rec e = lazy (fun _ -> f) and f = ();;
+++ /dev/null
-
-# Characters 12-18:
- let rec a = lazy b and b = 3;;
- ^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# val e : ('a -> unit) lazy_t = lazy <fun>
-val f : unit = ()
-#
--- /dev/null
+Characters 39-45:
+ let rec a = lazy b and b = 3;;
+ ^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+val e : ('a -> unit) lazy_t = lazy <fun>
+val f : unit = ()
+
+(* TEST
+ * toplevel
+*)
+
module type S = sig val y : float end;;
module type T = sig val x : float val y : float end;;
type t = T : (module S) -> t;;
+++ /dev/null
-
-# module type S = sig val y : float end
-# module type T = sig val x : float val y : float end
-# type t = T : (module S) -> t
-# Characters 13-51:
- let rec x = let module M = (val m) in T (module M)
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-#
--- /dev/null
+module type S = sig val y : float end
+module type T = sig val x : float val y : float end
+type t = T : (module S) -> t
+Characters 13-51:
+ let rec x = let module M = (val m) in T (module M)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+
--- /dev/null
+disallowed.ml
+extension_constructor.ml
+float_block_allowed.ml
+float_block_disallowed.ml
+generic_arrays.ml
+labels.ml
+lazy_.ml
+module_constraints.ml
+pr7215.ml
+pr7231.ml
+pr7706.ml
+unboxed.ml
+(* TEST
+ * toplevel
+*)
+
(* From Stephen Dolan *)
type (_,_) eq = Refl : ('a, 'a) eq;;
let cast (type a) (type b) (Refl : (a, b) eq) (x : a) = (x : b);;
+++ /dev/null
-
-# type (_, _) eq = Refl : ('a, 'a) eq
-# val cast : ('a, 'b) eq -> 'a -> 'b = <fun>
-# Characters 53-78:
- let rec (p : (int, a) eq) = match p with Refl -> Refl in
- ^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-#
--- /dev/null
+type (_, _) eq = Refl : ('a, 'a) eq
+val cast : ('a, 'b) eq -> 'a -> 'b = <fun>
+Characters 53-78:
+ let rec (p : (int, a) eq) = match p with Refl -> Refl in
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+
+(* TEST
+ * toplevel
+*)
+
let rec r = let rec x () = r and y () = x () in y () in r "oops";;
+++ /dev/null
-
-# Characters 58-64:
- let rec r = let rec x () = r and y () = x () in y () in r "oops";;
- ^^^^^^
-Warning 20: this argument will not be used by the function.
-Characters 12-52:
- let rec r = let rec x () = r and y () = x () in y () in r "oops";;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-#
--- /dev/null
+Characters 84-90:
+ let rec r = let rec x () = r and y () = x () in y () in r "oops";;
+ ^^^^^^
+Warning 20: this argument will not be used by the function.
+Characters 38-78:
+ let rec r = let rec x () = r and y () = x () in y () in r "oops";;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+
--- /dev/null
+(* TEST
+ * toplevel
+*)
+let rec x =
+ let y = if false then (fun z -> 1) else (fun z -> x 4 + 1) in
+ y;;
+
+let () = ignore (x 42);;
--- /dev/null
+Characters 39-104:
+ ..let y = if false then (fun z -> 1) else (fun z -> x 4 + 1) in
+ y..
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 18-19:
+ let () = ignore (x 42);;
+ ^
+Error: Unbound value x
+
+(* TEST
+ * toplevel
+*)
+
type t = {x: int64} [@@unboxed];;
let rec x = {x = y} and y = 3L;;
type r = A of r [@@unboxed];;
let rec y = A y;;
+type a = {a: b }[@@unboxed]
+and b = X of a | Y
+
+let rec a =
+ {a=
+ (if Sys.opaque_identity true then
+ X a
+ else
+ Y)};;
+
+type d = D of e [@@unboxed]
+and e = V of d | W;;
+
+let rec d =
+ D
+ (if Sys.opaque_identity true then
+ V d
+ else
+ W);;
+++ /dev/null
-
-# type t = { x : int64; } [@@unboxed]
-# Characters 12-19:
- let rec x = {x = y} and y = 3L;;
- ^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# type r = A of r [@@unboxed]
-# Characters 12-15:
- let rec y = A y;;
- ^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-#
--- /dev/null
+type t = { x : int64; } [@@unboxed]
+Characters 12-19:
+ let rec x = {x = y} and y = 3L;;
+ ^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+type r = A of r [@@unboxed]
+Characters 12-15:
+ let rec y = A y;;
+ ^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+Characters 77-150:
+ ..{a=
+ (if Sys.opaque_identity true then
+ X a
+ else
+ Y)}..
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+type d = D of e [@@unboxed]
+and e = V of d | W
+Characters 15-85:
+ ..D
+ (if Sys.opaque_identity true then
+ V d
+ else
+ W)..
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
let rec x = (x; ());;
let rec x = let x = () in x;;
let rec x = { contents = y }
and y = fun () -> ignore x;;
-
+
let r = ref (fun () -> ())
let rec x = fun () -> r := x;;
= `Tuple [| `Shared deep_cycle |];;
(* Constructing float arrays was disallowed altogether at one point
- by an overzealous check. Constructing float arrays in recursive
+ by an overzealous check. Constructing float arrays in recursive
bindings is fine when they don't partake in the recursion. *)
let rec _x = let _ = [| 1.0 |] in 1. in ();;
+
+(* This test is not allowed if 'a' is unboxed, but should be accepted
+ as written *)
+type a = {a: b}
+and b = X of a | Y
+
+let rec a =
+ {a=
+ (if Sys.opaque_identity true then
+ X a
+ else
+ Y)};;
+
+(* This test is not allowed if 'c' is unboxed, but should be accepted
+ as written *)
+type d = D of e
+and e = V of d | W;;
+
+let rec d =
+ D
+ (if Sys.opaque_identity true then
+ V d
+ else
+ W);;
+
+type r = R of r list [@@unboxed];;
+let rec a = R [a];;
+(* TEST *)
+
(* testing backreferences; some compilation scheme may handle
differently recursive references to a mutually-recursive RHS
depending on whether it is before or after in the bindings list *)
+(* TEST *)
+
(* class expression are compiled to recursive bindings *)
class test =
object
+(* TEST *)
+
(* class expressions may also contain local recursive bindings *)
class test =
let rec f = print_endline "f"; fun x -> g x
+++ /dev/null
-
-# Characters 12-27:
- let rec x = let y = () in x;;
- ^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-77:
- let rec x = let module M = struct let f = x let g = x () end in fun () -> ();;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-77:
- let rec x = let module M = struct let f = x () let g = x end in fun () -> ();;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-79:
- let rec x = (let module M = struct let f = y 0 let g = () end in fun () -> ())
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-79:
- let rec x = let module M = struct module N = struct let y = x end end in M.N.y;;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-77:
- let rec x = let module M = struct let f = x () and g = x end in fun () -> ();;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# class c : 'a -> object end
-# Characters 12-19:
- let rec x = new c x;;
- ^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-21:
- let rec x = ignore x;;
- ^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-16:
- let rec x = y 0 and y _ = ();;
- ^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-18:
- let rec x = [|y|]
- ^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-40:
- let rec c = { c with Complex.re = 1.0 };;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-36:
- let rec x = { x with contents = 3 };;
- ^^^^^^^^^^^^^^^^^^^^^^^
-Warning 23: all the fields are explicitly listed in this record:
-the 'with' clause is useless.
-Characters 13-36:
- let rec x = { x with contents = 3 };;
- ^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-38:
- let rec b = if b then true else false;;
- ^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 28-34:
- let rec x = r := x;;
- ^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-65:
- ..for i = 0 to 1 do
- let z = y in ignore z
- done
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-46:
- ..for i = 0 to y do
- ()
- done
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-47:
- ..for i = y to 10 do
- ()
- done
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-62:
- ..while false do
- let y = x in ignore y
- done
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-39:
- ..while y do
- ()
- done
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-58:
- ..while y do
- let y = x in ignore y
- done
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-45:
- let rec x = (object method m _ = () end)#m x;;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-23:
- let rec x = y.contents and y = { contents = 3 };;
- ^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-59:
- let rec x = object val mutable v = 0 method m = v <- y end and y = 1;;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-21:
- let rec x = assert y and y = true;;
- ^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-36:
- let rec x = object method m = x end;;
- ^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-43:
- let rec x = object method m = ignore x end;;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# * Characters 230-246:
- let rec x = Pervasives.ref y
- ^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# * Characters 127-175:
- if p then (fun y -> x + g y) else (fun y -> g y)
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 13-33:
- let rec x = let y = (x; ()) in y;;
- ^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-58:
- ..for i = 0 to 1 do
- let z = y in z
- done
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 37-61:
- let rec x = (module (val y : T) : T)
- ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-55:
- ..while false do
- let y = x in y
- done
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 15-98:
- ..match let _ = y in raise Not_found with
- _ -> "x"
- | exception Not_found -> "z".
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-#
+(* TEST *)
+
(* test evaluation order
'y' is translated into a constant, and is therefore considered
+(* TEST *)
+
(* A variant of evaluation_order_1.ml where the side-effects
are inside the blocks.
Effect are not named to allow different evaluation orders (flambda
+(* TEST *)
+
type t = { x : t; y : t }
let p = print_endline
+(* TEST *)
+
(* Effect are not named to allow different evaluation orders (flambda
and clambda differ on this point).
*)
+(* TEST *)
+
let rec x = let _y = [| |] in ();;
let rec x = let y = [| |] in y :: x;;
--- /dev/null
+(* TEST *)
+
+let f () ~x = x ()
+let rec x = f ~x
+(* TEST *)
+
let rec c = lazy (0 + d) and d = 3;;
let () = Printf.printf "%d\n" (Lazy.force c)
+(* TEST *)
+
(* a test with lists, because cyclic lists are fun *)
let test =
let rec li = 0::1::2::3::4::5::6::7::8::9::li in
+(* TEST *)
+
(* mixing values and closures may exercise interesting code paths *)
type t = A of (int -> int)
let test =
+(* TEST *)
+
(* a polymorphic variant of test3.ml; found a real bug once *)
let test =
let rec x = `A f
+(* TEST *)
+
(* a simple test with mutually recursive functions *)
let test =
let rec even = function
+(* TEST *)
+
(* Mantis PR7447 *)
let rec r = (let rec x = `A r and y = fun () -> x in y)
-let (`A x) = r ()
+let (`A x) = r ()
let _ = x ()
--- /dev/null
+allowed.ml
+backreferences.ml
+class_1.ml
+class_2.ml
+evaluation_order_1.ml
+evaluation_order_2.ml
+evaluation_order_3.ml
+float_block_1.ml
+generic_array.ml
+labels.ml
+lazy_.ml
+lists.ml
+mixing_value_closures_1.ml
+mixing_value_closures_2.ml
+mutual_functions.ml
+nested.ml
+pr4989.ml
+record_with.ml
+ref.ml
+(* TEST *)
+
let rec f = let g = f in fun x -> g x;;
+(* TEST *)
+
(* A regression test for both PR#4141 and PR#5819: when a recursive
variable is defined by a { record with ... } expression.
*)
+(* TEST *)
+
(* Test construction of cyclic values where the cycles pass through references *)
type t = { mutable next : t; mutable inst : n ref }
+++ /dev/null
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+uchar_esc.ml
+(* TEST
+ * toplevel
+*)
(* Correct escapes and their encoding *)
+++ /dev/null
-
-# # Characters 34-43:
- let invalid_sv = "\u{0D800}" ;;
- ^^^^^^^^^
-Error: Illegal backslash escape in string or character (\u{0D800}, D800 is not a Unicode scalar value)
-# Characters 18-26:
- let invalid_sv = "\u{D800}" ;;
- ^^^^^^^^
-Error: Illegal backslash escape in string or character (\u{D800}, D800 is not a Unicode scalar value)
-# Characters 18-26:
- let invalid_sv = "\u{D900}" ;;
- ^^^^^^^^
-Error: Illegal backslash escape in string or character (\u{D900}, D900 is not a Unicode scalar value)
-# Characters 18-26:
- let invalid_sv = "\u{DFFF}" ;;
- ^^^^^^^^
-Error: Illegal backslash escape in string or character (\u{DFFF}, DFFF is not a Unicode scalar value)
-# Characters 18-28:
- let invalid_sv = "\u{110000} ;;
- ^^^^^^^^^^
-Error: Illegal backslash escape in string or character (\u{110000}, 110000 is not a Unicode scalar value)
-# Characters 24-36:
- let too_many_digits = "\u{01234567}" ;;
- ^^^^^^^^^^^^
-Error: Illegal backslash escape in string or character (\u{01234567}, too many digits, expected 1 to 6 hexadecimal digits)
-# Characters 21-23:
- let no_hex_digits = "\u{}" ;;
- ^^
-Warning 14: illegal backslash escape in string.
-val no_hex_digits : string = "\\u{}"
-# Characters 25-27:
- let illegal_hex_digit = "\u{u}" ;;
- ^^
-Warning 14: illegal backslash escape in string.
-val illegal_hex_digit : string = "\\u{u}"
-#
--- /dev/null
+Characters 34-43:
+ let invalid_sv = "\u{0D800}" ;;
+ ^^^^^^^^^
+Error: Illegal backslash escape in string or character (\u{0D800}, D800 is not a Unicode scalar value)
+Characters 18-26:
+ let invalid_sv = "\u{D800}" ;;
+ ^^^^^^^^
+Error: Illegal backslash escape in string or character (\u{D800}, D800 is not a Unicode scalar value)
+Characters 18-26:
+ let invalid_sv = "\u{D900}" ;;
+ ^^^^^^^^
+Error: Illegal backslash escape in string or character (\u{D900}, D900 is not a Unicode scalar value)
+Characters 18-26:
+ let invalid_sv = "\u{DFFF}" ;;
+ ^^^^^^^^
+Error: Illegal backslash escape in string or character (\u{DFFF}, DFFF is not a Unicode scalar value)
+Characters 18-28:
+ let invalid_sv = "\u{110000} ;;
+ ^^^^^^^^^^
+Error: Illegal backslash escape in string or character (\u{110000}, 110000 is not a Unicode scalar value)
+Characters 24-36:
+ let too_many_digits = "\u{01234567}" ;;
+ ^^^^^^^^^^^^
+Error: Illegal backslash escape in string or character (\u{01234567}, too many digits, expected 1 to 6 hexadecimal digits)
+Characters 21-23:
+ let no_hex_digits = "\u{}" ;;
+ ^^
+Warning 14: illegal backslash escape in string.
+val no_hex_digits : string = "\\u{}"
+Characters 25-27:
+ let illegal_hex_digit = "\u{u}" ;;
+ ^^
+Warning 14: illegal backslash escape in string.
+val illegal_hex_digit : string = "\\u{u}"
+
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Damien Doligez, projet Gallium, INRIA Rocquencourt *
-#* *
-#* Copyright 2013 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+testarg.ml
+testerror.ml
+(* TEST
+*)
+
let current = ref 0;;
let accum = ref [];;
+(* TEST
+*)
+
(** Test that the right message errors are emitted by Arg *)
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-LIBRARIES=unix bigarray
-ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
- -I $(OTOPDIR)/otherlibs/bigarray
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/bigarray
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ include unix
+*)
+
open Bigarray
(* Test harness *)
--- /dev/null
+mapfile.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-LIBRARIES=unix bigarray
-ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
- -I $(OTOPDIR)/otherlibs/bigarray
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/bigarray
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
open Bigarray
open Printf
open Complex
+(* TEST
+*)
+
(** Test the various change_layout for Genarray and the various Array[n] *)
open Bigarray
+(* TEST
+*)
+
open Bigarray
let pi = 3.14159265358979323846
--- /dev/null
+bigarrays.ml
+change_layout.ml
+fftba.ml
+pr5115.ml
+weak_bigarray.ml
+(* TEST
+*)
+
(* PR#5115 - multiple evaluation of bigarray expr *)
open Bigarray
-
+(* TEST
+*)
(** check that custom block are not copied by Weak.get_copy *)
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
open Printf
;;
let () = print_string "Standard Library: Module Buffer\n"
;;
-let truncate_neg : unit =
+let truncate_neg : unit =
let msg = "truncate: negative" in
- try
+ try
Buffer.truncate buf (-1);
failed msg
with
;;
let truncate_correct : unit =
- let n' = n - 1
+ let n' = n - 1
and msg = "truncate: in-range" in
try
Buffer.truncate buf n';
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-MODULES=testing
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+test_bytes.ml
+(* TEST
+ include testing
+*)
+
let test_raises_invalid_argument f x =
ignore
(Testing.test_raises_exc_p (function Invalid_argument _ -> true | _ -> false)
begin
(*
abcde
- ?????
+ ?????
*)
Testing.test
- (length (extend abcde 7 (-7)) = 5);
+ (length (extend abcde 7 (-7)) = 5);
(*
abcde
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-#MODULES=
-MAIN_MODULE=md5
-ADD_COMPFLAGS=-w a
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ flags += " -w a "
+*)
+
(* Test int32 arithmetic and optimizations using the MD5 algorithm *)
open Printf
data
let int32_to_string n s i =
- s.[i+3] <- Char.chr (Int32.to_int (Int32.shift_right n 24) land 0xFF);
- s.[i+2] <- Char.chr (Int32.to_int (Int32.shift_right n 16) land 0xFF);
- s.[i+1] <- Char.chr (Int32.to_int (Int32.shift_right n 8) land 0xFF);
- s.[i] <- Char.chr (Int32.to_int n land 0xFF)
+ Bytes.set s (i+3) (Char.chr (Int32.to_int (Int32.shift_right n 24) land 0xFF));
+ Bytes.set s (i+2) (Char.chr (Int32.to_int (Int32.shift_right n 16) land 0xFF));
+ Bytes.set s (i+1) (Char.chr (Int32.to_int (Int32.shift_right n 8) land 0xFF));
+ Bytes.set s i (Char.chr (Int32.to_int n land 0xFF))
let init () =
{ buf = Bytes.create 64;
(* Callback must be linked to load Unix dynamically *)
let _ = Callback.register
-module CamlinternalBigarray = CamlinternalBigarray
+let _ = Stdlib.Bigarray.float32
let () =
ignore (Hashtbl.hash 42.0);
plugin_high_arity.so plugin_ext.so plugin_simple.so bug.so \
plugin_thread.so plugin4_unix.so a.so b.so c.so
-ADD_COMPFLAGS=-thread
-
.PHONY: compile
compile: $(PLUGINS) main$(EXE) mylib.so
&& echo " => passed" || echo " => failed"
main$(EXE): api.cmx main.cmx
- @$(OCAMLOPT) -thread -o main$(EXE) -linkall unix.cmxa threads.cmxa \
+ @$(OCAMLOPT) -I +threads -o main$(EXE) -linkall unix.cmxa threads.cmxa \
dynlink.cmxa api.cmx main.cmx
main_ext$(EXE): api.cmx main.cmx factorial.$(O)
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
let () =
let test f e =
assert(Filename.extension f = e);
--- /dev/null
+extension.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-MODULES=testing
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+pr6824.ml
+tformat.ml
+(* TEST
+ include testing
+*)
+
let f = Format.sprintf "[%i]";;
print_endline (f 1);;
print_endline (f 2);;
+(* TEST
+ include testing
+*)
+
(*
A test file for the Format module.
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
(* Testing the hash function Hashtbl.hash *)
(* What is tested:
- reproducibility on various platforms, esp. 32/64 bit issues
+(* TEST
+*)
+
(* Hashtable operations, using maps as a reference *)
open Printf
true
with Exit | Not_found -> false
+ let to_list_ h : _ list =
+ H.fold (fun k v acc -> (k,v) :: acc) h []
+ |> List.sort Pervasives.compare
+
+ let check_to_seq h =
+ let l = to_list_ h in
+ let l2 = List.of_seq (H.to_seq h) in
+ assert (l = List.sort Pervasives.compare l2)
+
+ let check_to_seq_of_seq h =
+ let h' = H.create (H.length h) in
+ H.add_seq h' (H.to_seq h);
+ (*printf "h.len=%d, h'.len=%d\n" (List.length @@ to_list_ h) (List.length @@ to_list_ h');*)
+ assert (to_list_ h = to_list_ h')
+
let test data =
let n = Array.length data in
let h = H.create 51 and m = ref M.empty in
data;
printf "Insertion: %s\n"
(if incl_mh !m h && domain_hm h !m then "passed" else "FAILED");
+ check_to_seq_of_seq h;
+ check_to_seq h;
(* Insert all data with H.replace *)
H.clear h; m := M.empty;
Array.iter
data;
printf "Insertion: %s\n"
(if incl_mh !m h && incl_hm h !m then "passed" else "FAILED");
+ check_to_seq_of_seq h;
+ check_to_seq h;
(* Remove some of the data *)
for i = 0 to n/3 - 1 do
let (k, _) = data.(i) in H.remove h k; m := M.remove k !m
done;
printf "Removal: %s\n"
- (if incl_mh !m h && incl_hm h !m then "passed" else "FAILED")
+ (if incl_mh !m h && incl_hm h !m then "passed" else "FAILED");
+ check_to_seq_of_seq h;
+ check_to_seq h;
+ ()
end
let length = Hashtbl.length
let stats = Hashtbl.stats
let filter_map_inplace = Hashtbl.filter_map_inplace
+ let to_seq = Hashtbl.to_seq
+ let to_seq_keys = Hashtbl.to_seq_keys
+ let to_seq_values = Hashtbl.to_seq_values
+ let of_seq = Hashtbl.of_seq
+ let add_seq = Hashtbl.add_seq
+ let replace_seq = Hashtbl.replace_seq
end
module HS1 = HofM(MS)
--- /dev/null
+hfun.ml
+htbl.ml
+++ /dev/null
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
(* Standard test case *)
let () =
let l = List.init 10 (fun x -> x) in
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-#MODULES=
-MAIN_MODULE=intext
-C_FILES=intextaux
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ modules = "intextaux.c"
+*)
+
(* Test for output_value / input_value *)
let max_data_depth = 500000
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-MODULES=
-MAIN_MODULE=reachable_words
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+reachable_words.ml
+(* TEST
+*)
+
let native =
- match Filename.basename Sys.argv.(0) with
- | "program.byte" | "program.byte.exe" -> false
- | "program.native" | "program.native.exe" -> true
- | s -> print_endline s; assert false
+ match Sys.backend_type with
+ | Sys.Native -> true
+ | Sys.Bytecode -> false
+ | Sys.Other s -> print_endline s; assert false
let size x = Obj.reachable_words (Obj.repr x)
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-MODULES=testing
-BASEDIR=../..
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+pr6534.ml
+pr6938.ml
+tprintf.ml
+(* TEST
+ include testing
+*)
+
(* these are not valid under -strict-formats, but we test them here
for backward-compatibility *)
open Printf
+(* TEST
+ include testing
+*)
+
(* these are not valid under -strict-formats, but we test them here
for backward-compatibility *)
+(* TEST
+ include testing
+*)
+
(*
A test file for the Printf module.
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
module Q = struct
include Queue
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
(* Test that two Random.self_init() in close succession will not result
in the same PRNG state.
Note that even when the code is correct this test is expected to fail
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-
-COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-
-MYRUNTIME=`if [ -z "$(CUSTOM)" ]; then echo '$(OCAMLRUN)'; fi`
-
-.PHONY: default
-default:
- @$(MAKE) compile
- @$(SET_LD_PATH) $(MAKE) run
-
-.PHONY: compile
-compile: tscanf2_io.cmo
- @rm -f master.byte master.native master.native.exe
- @rm -f slave.byte slave.native slave.native.exe
- @$(OCAMLC) unix.cma tscanf2_io.cmo -o master.byte tscanf2_master.ml
- @$(OCAMLC) tscanf2_io.cmo -o slave.byte tscanf2_slave.ml
- @if $(BYTECODE_ONLY); then : ; else \
- $(MAKE) tscanf2_io.cmx; \
- $(OCAMLOPT) unix.cmxa tscanf2_io.cmx -o master.native$(EXE) \
- tscanf2_master.ml; \
- $(OCAMLOPT) tscanf2_io.cmx -o slave.native$(EXE) tscanf2_slave.ml; \
- fi
-
-run:
- @printf " ... testing with ocamlc"
- @$(MYRUNTIME) ./master.byte "$(OTOPDIR)/boot/ocamlrun$(EXE) \
- `$(CYGPATH) ./slave.byte`" \
- >result.byte 2>&1
- @$(DIFF) reference result.byte >/dev/null \
- && if $(BYTECODE_ONLY); then : ; else \
- printf " ocamlopt"; \
- ./master.native$(EXE) "`$(CYGPATH) ./slave.native`" \
- >result.native 2>&1; \
- $(DIFF) reference result.native >/dev/null; \
- fi \
- && echo " => passed" || echo " => failed"
-
-.PHONY: promote
-promote:
- @cp result.byte reference
-
-.PHONY: clean
-clean: defaultclean
- @rm -f master.* slave.* result.*
-
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+tscanf2_master.ml
+(* TEST
+
+include unix
+modules = "tscanf2_io.ml"
+files = "tscanf2_slave.ml"
+reference = "${test_source_directory}/reference"
+
+(* The bytcode test *)
+
+* setup-ocamlc.byte-build-env
+
+program = "${test_build_directory}/master.byte"
+
+** ocamlc.byte (* Compiles the master *)
+
+*** ocamlc.byte (* Compiles the slave *)
+
+all_modules = "tscanf2_io.cmo tscanf2_slave.ml"
+
+program = "${test_build_directory}/slave.byte"
+
+**** check-ocamlc.byte-output
+
+***** run
+
+program = "${test_build_directory}/master.byte"
+
+arguments = "${test_build_directory}/slave.byte"
+
+****** check-program-output
+
+(* The native test *)
+
+* setup-ocamlopt.byte-build-env
+
+program = "${test_build_directory}/master.opt"
+
+** ocamlopt.byte (* Compiles the master *)
+
+*** ocamlopt.byte (* Compiles the slave *)
+
+all_modules = "tscanf2_io.cmx tscanf2_slave.ml"
+
+program = "${test_build_directory}/slave.opt"
+
+**** check-ocamlopt.byte-output
+
+***** run
+
+program = "${test_build_directory}/master.opt"
+
+arguments = "${test_build_directory}/slave.opt"
+
+****** check-program-output
+
+*)
+
(* A very simple master:
- first launch a slave process,
- then repeat a random number of times:
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-#MODULES=
-MAIN_MODULE=tscanf
-ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib
-ADD_MODULES=testing
-TEST_TEMP_FILES=tscanf_data
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ include testing
+*)
+
(*
A testbed file for the module Scanf.
--- /dev/null
+(* TEST
+*)
+
+let filter1 x = x mod 2 = 0 ;;
+
+(* Standard test case *)
+let () =
+ assert
+ ([2;4] =
+ (List.to_seq [1;2;3;4;5]
+ |> Seq.filter (fun x -> x mod 2 = 0)
+ |> List.of_seq));
+ ()
+;;
+
+let () = print_endline "OK";;
+
+
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+testmap.ml
+testset.ml
+(* TEST
+*)
+
module M = Map.Make(struct type t = int let compare (x:t) y = compare x y end)
let img x m = try Some(M.find x m) with Not_found -> None
fun i ->
if i < x then img i l = img i s1
else if i > x then img i r = img i s1
- else p = img i s1)
+ else p = img i s1);
+
+ checkbool "to_seq_of_seq"
+ (M.equal (=) s1 (M.of_seq @@ M.to_seq s1));
+
+ checkbool "to_seq_from"
+ (let seq = M.to_seq_from x s1 in
+ let ok1 = List.of_seq seq |> List.for_all (fun (y,_) -> y >= x) in
+ let ok2 =
+ (M.to_seq s1 |> List.of_seq |> List.filter (fun (y,_) -> y >= x))
+ =
+ (List.of_seq seq)
+ in
+ ok1 && ok2);
+
+ ()
let rkey() = Random.int 10
+(* TEST
+*)
+
module S = Set.Make(struct type t = int let compare (x:t) y = compare x y end)
let testvals = [0;1;2;3;4;5;6;7;8;9]
fun i ->
if i < x then S.mem i l = S.mem i s1
else if i > x then S.mem i r = S.mem i s1
- else p = S.mem i s1)
+ else p = S.mem i s1);
+
+ checkbool "to_seq_of_seq"
+ (S.equal s1 (S.of_seq @@ S.to_seq s1));
+
+ checkbool "to_seq_from"
+ (let seq = S.to_seq_from x s1 in
+ let ok1 = List.of_seq seq |> List.for_all (fun y -> y >= x) in
+ let ok2 =
+ (S.elements s1 |> List.filter (fun y -> y >= x))
+ =
+ (List.of_seq seq)
+ in
+ ok1 && ok2);
+
+ ()
let relt() = Random.int 10
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
module S = struct
include Stack
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-ADD_COMPFLAGS=-nolabels
-BASEDIR=../..
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+test_stdlabels.ml
+(* TEST
+ flags += " -nolabels "
+*)
+
module A : module type of Array = ArrayLabels
module B : module type of Bytes = BytesLabels
module L : module type of List = ListLabels
module S : module type of String = StringLabels
-module M : module type of Map = MoreLabels.Map
-module Se : module type of Set = MoreLabels.Set
+module M : module type of struct include Map end [@remove_aliases] =
+ MoreLabels.Map
+
+module Se : module type of struct include Set end [@remove_aliases] =
+ MoreLabels.Set
(* For *)
end
module type HS = sig
type statistics = Indirection.t
- include module type of Hashtbl
+ include module type of struct include Hashtbl end [@remove_aliases]
with type statistics := Indirection.t
end
module H : HS = MoreLabels.Hashtbl
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-LIBRARIES=str
-ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/str
-LD_PATH=$(TOPDIR)/otherlibs/str
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ include str
+*)
+
open Printf
let build_result ngroups input =
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-MODULES=testing
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ include testing
+*)
+
let is_empty s =
try Stream.empty s; true with Stream.Failure -> false
--- /dev/null
+(* TEST
+ files = "mpr7769.txt"
+*)
+
+let () =
+ let s = Stream.of_channel (open_in "mpr7769.txt") in
+ Stream.junk s;
+ print_char (Stream.next s);
+ print_newline ()
--- /dev/null
+count_concat_bug.ml
+mpr7769.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-LIBRARIES=str
-ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/str
-LD_PATH=$(TOPDIR)/otherlibs/str
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+test_string.ml
+(* TEST
+*)
+
let rec build_string f n accu =
if n <= 0
then String.concat "" accu
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
-
-# Not really generated sources but temp files that need cleaning
-GENERATED_SOURCES=file1.dat file2.dat
+(* TEST
+*)
+
(* Test the Sys.rename function *)
let writefile filename contents =
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-LIBRARIES=unix threads
-ADD_COMPFLAGS=-thread -I $(OTOPDIR)/otherlibs/systhreads \
- -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-LD_PATH=$(TOPDIR)/otherlibs/systhreads:$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+testfork.ml
+testpreempt.ml
+(* TEST
+ include systhreads
+ * not-bsd
+ ** libunix
+ *** bytecode
+ *** native
+*)
+
(* POSIX threads and fork() *)
let compute_thread c = ignore c
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Damien Doligez, projet Gallium, INRIA Rocquencourt *
-#* *
-#* Copyright 2013 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-case `grep '^SYSTEM=' ../../../config/Makefile` in
- SYSTEM=bsd_elf) exit 3;;
-esac
-
-case `sed -n -e '/OTHERLIBRARIES=/s// /p' ../../../config/Makefile` in
- *' unix'*) exit 0;;
- *) exit 3;;
-esac
--- /dev/null
+(* TEST
+ (*
+ On Windows, we use Sleep(0) for triggering preemption of threads.
+ However, this does not seem very reliable, so that this test fails
+ on some Windows configurations. See GPR #1533.
+ *)
+ include systhreads
+ * not-windows
+ ** bytecode
+ ** native
+*)
+
+let rec generate_list n =
+ let rec aux acc = function
+ | 0 -> acc
+ | n -> aux (float n :: acc) (n-1)
+ in
+ aux [] n
+
+let rec long_computation time0 =
+ let long_list = generate_list 100000 in
+ let res = List.length (List.rev_map sin long_list) in
+ if Sys.time () -. time0 > 2. then
+ Printf.printf "Long computation result: %d\n%!" res
+ else long_computation time0
+
+let interaction () =
+ Thread.delay 0.1;
+ Printf.printf "Interaction 1\n";
+ Thread.delay 0.1;
+ Printf.printf "Interaction 2\n"
+
+let () =
+ ignore (Thread.create interaction ());
+ long_computation (Sys.time ())
--- /dev/null
+Interaction 1
+Interaction 2
+Long computation result: 100000
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-LIBRARIES=unix threads
-ADD_COMPFLAGS=-thread -I $(OTOPDIR)/otherlibs/systhreads \
- -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-LD_PATH=$(TOPDIR)/otherlibs/systhreads:$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-
-default:
- @$(if $(filter msvc mingw,$(TOOLCHAIN)),$(MAKE) sigint.exe,true)
- @$(SET_LD_PATH) $(MAKE) run-all
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
-
-sigint.exe: sigint.$(O)
- @$(CC) $(if $(filter msvc,$(CCOMPTYPE)),/Fe$@,-o $@) $^
-
-%.obj: %.c
- @$(CC) -c $*.c > /dev/null
+(* TEST
+
+include systhreads
+
+*)
let () = Printexc.record_backtrace true
+(* TEST
+
+include systhreads
+
+*)
+
(* The bank account example, using events and channels *)
open Printf
+(* TEST
+
+include systhreads
+
+*)
+
(* Test Thread.delay and its scheduling *)
open Printf
+(* TEST
+
+include systhreads
+
+*)
+
open Event
type 'a buffer_channel = {
+(* TEST
+
+include systhreads
+
+*)
+
let main () =
let (rd, wr) = Unix.pipe() in
let t = Thread.create
+(* TEST
+
+include systhreads
+
+*)
+
(* Test a file copy function *)
let test msg producer consumer src dst =
--- /dev/null
+backtrace_threads.ml
+bank.ml
+beat.ml
+bufchan.ml
+close.ml
+fileio.ml
+pr4466.ml
+pr5325.ml
+pr7638.ml
+prodcons.ml
+prodcons2.ml
+sieve.ml
+signal.ml
+sockets.ml
+swapchan.ml
+tls.ml
+torture.ml
+(* TEST
+
+include systhreads
+
+* libunix (* Broken on Windows (missing join?), needs to be fixed *)
+** bytecode
+** native
+
+*)
+
open Printf
(* Regression test for PR#4466: select timeout with simultaneous read
+(* TEST
+
+include systhreads
+
+* libunix (* Broken on Windows (missing join?), needs to be fixed *)
+** bytecode
+** native
+
+*)
+
open Printf
(* Regression test for PR#5325: simultaneous read and write on socket
+(* TEST
+
+include systhreads
+
+*)
+
(* MPR#7638 repro case *)
let crashme v =
+(* TEST
+
+include systhreads
+
+*)
+
(* Classic producer-consumer *)
type 'a prodcons =
+(* TEST
+
+include systhreads
+
+*)
+
(* Producer-consumer with events and multiple producers *)
open Event
+(* TEST
+
+include systhreads
+
+*)
+
let sieve primes =
Event.sync (Event.send primes 2);
let integers = Event.new_channel () in
#include <stdio.h>
-#include <windows.h>
+
+#ifdef _WIN32
+ #include <windows.h>
+#else
+ #include <stdlib.h>
+ #include <sys/types.h>
+ #include <signal.h>
+#endif
int main(int argc, char** argv)
{
+#ifdef _WIN32
DWORD pid;
HANDLE hProcess;
+#else
+ pid_t pid;
+#endif
if (argc != 2) {
printf("Usage: %s pid\n", argv[0]);
}
pid = atoi(argv[1]);
+#ifdef _WIN32
hProcess = OpenProcess(SYNCHRONIZE, FALSE, pid);
if (!hProcess) {
WaitForSingleObject(hProcess, INFINITE);
CloseHandle(hProcess);
FreeConsole();
+#else
+ if (kill(pid,SIGINT)) {
+ perror("kill");
+ return 1;
+ }
+#endif
return 0;
}
--- /dev/null
+if sed -e 1q ${output} | grep -q '^[ab]*Got ctrl-C, exiting$';
+then
+ exit ${TEST_PASS}
+else
+ exit ${TEST_FAIL};
+fi
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-sed -e 1q signal.result | grep -q '^[ab]*Got ctrl-C, exiting...[ab]\{0,2\}$'
+(* TEST
+
+include systhreads
+
+files = "sigint.c"
+
+* libunix (* excludes mingw32/64 and msvc32/64 *)
+
+** setup-ocamlc.byte-build-env
+
+program = "${test_build_directory}/signal.byte"
+
+*** ocamlc.byte
+
+program = "sigint"
+all_modules = "sigint.c"
+
+**** ocamlc.byte
+
+program = "${test_build_directory}/signal.byte"
+all_modules = "signal.ml"
+
+***** check-ocamlc.byte-output
+****** run
+******* check-program-output
+
+** setup-ocamlopt.byte-build-env
+
+program = "${test_build_directory}/signal.opt"
+
+*** ocamlopt.byte
+
+program = "sigint"
+all_modules = "sigint.c"
+
+**** ocamlc.byte
+
+program = "${test_build_directory}/signal.opt"
+all_modules = "signal.ml"
+
+***** check-ocamlopt.byte-output
+****** run
+******* check-program-output
+
+*)
+
+let signaled = ref false
+
+let counter = ref 0
+
let sighandler _ =
- print_string "Got ctrl-C, exiting..."; print_newline();
- exit 0
+ signaled := true
let print_message delay c =
- while true do
+ while (not !signaled) && (!counter <= 20) do
+ incr counter;
print_char c; flush stdout; Thread.delay delay
done
let _ =
ignore (Sys.signal Sys.sigint (Sys.Signal_handle sighandler));
- ignore (Thread.create (print_message 0.6666666666) 'a');
- print_message 1.0 'b'
+ let th1 = Thread.create (print_message 0.6666666666) 'a' in
+ print_message 1.0 'b';
+ Thread.join th1;
+ if !signaled then begin
+ print_string "Got ctrl-C, exiting"; print_newline();
+ exit 0
+ end else begin
+ print_string "not signaled???"; print_newline();
+ exit 2
+ end
+++ /dev/null
-test "$TOOLCHAIN" != "msvc" -a "$TOOLCHAIN" != "mingw"
--- /dev/null
+${program} > ${output} &
+pid=$!
+sleep 2
+./sigint $pid
+wait
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-$RUNTIME ./program >signal.result &
-pid=$!
-sleep 2
-test -e ./sigint.exe && ./sigint $pid || kill -INT $pid
+(* TEST
+
+include systhreads
+
+* libunix (* Broken on Windows (missing join?), needs to be fixed *)
+** bytecode
+** native
+
+*)
+
open Printf
(* Threads and sockets *)
+++ /dev/null
-open Printf
-
-(* Threads, sockets, and buffered I/O channels *)
-(* Serves as a regression test for PR#5578 *)
-
-let serve_connection s =
- let ic = Unix.in_channel_of_descr s
- and oc = Unix.out_channel_of_descr s in
- let l = input_line ic in
- fprintf oc ">>%s\n" l;
- close_out oc
-
-let server sock =
- while true do
- let (s, _) = Unix.accept sock in
- ignore(Thread.create serve_connection s)
- done
-
-let client (addr, msg) =
- let sock =
- Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
- Unix.connect sock addr;
- let ic = Unix.in_channel_of_descr sock
- and oc = Unix.out_channel_of_descr sock in
- output_string oc msg; flush oc;
- let l = input_line ic in
- printf "%s\n%!" l
-
-let _ =
- let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 0) in
- let sock =
- Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
- Unix.setsockopt sock Unix.SO_REUSEADDR true;
- Unix.bind sock addr;
- let addr = Unix.getsockname sock in
- Unix.listen sock 5;
- ignore (Thread.create server sock);
- ignore (Thread.create client (addr, "Client #1\n"));
- Thread.delay 0.5;
- client (addr, "Client #2\n")
+++ /dev/null
->>Client #1
->>Client #2
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Damien Doligez, Projet Gallium, INRIA Rocquencourt *
-#* *
-#* Copyright 2015 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-$SORT swapchan.result | $DIFF swapchan.reference - >/dev/null
+(* TEST
+
+include systhreads
+
+*)
+
open Event
type 'a swap_chan = ('a * 'a channel) channel
--- /dev/null
+${program} | ${SORT} > ${output} 2>&1
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-LC_ALL=C $SORT tls.result | $DIFF tls.reference -
+(* TEST
+
+include systhreads
+
+*)
+
let private_data = (Hashtbl.create 17 : (Thread.t, string) Hashtbl.t)
let private_data_lock = Mutex.create()
let output_lock = Mutex.create()
--- /dev/null
+${program} | LC_ALL=C ${SORT} > ${output} 2>&1
+(* TEST
+
+include systhreads
+
+*)
+
(* Torture test - I/O interspersed with lots of GC *)
let finished = ref false
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
let assert_raise_invalid_argument f v =
assert (try ignore (f v); false with Invalid_argument _ -> true)
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../../..
-LIBRARIES=unix
-ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-
-ifeq ($(OS),Windows_NT)
-ADD_BYTERUN_FLAGS="-I $(OTOPDIR)/otherlibs/win32unix"
-endif
-
-default: reflector.exe fdstatus.exe cmdline_prog.exe
- @$(MAKE) check
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
-
-%.exe: %.c
-ifeq ($(CCOMPTYPE),msvc)
- @set -o pipefail ; \
- $(CC) $(CFLAGS) $(CPPFLAGS) /Fe$*.exe $*.c | tail -n +2
-else
- @$(CC) $(CFLAGS) $(CPPFLAGS) -o $*.exe $*.c
-endif
+(* TEST
+
+(*
+ This test is temporarily disabled on the MinGW and MSVC ports,
+ because since fdstatus has been wrapped in an OCaml program,
+ it does not work as well as before.
+ Presumably this is because the OCaml runtime opens files, so that handles
+ that have actually been closed at execution look open and make the
+ test fail.
+
+ One possible fix for this would be to make it possible for ocamltest to
+ compile C-only programs, which will be a bit of work to handle the
+ output of msvc and will also duplicate what the ocaml compiler itslef
+ already does.
+*)
+
+include unix
+files = "fdstatus_aux.c fdstatus_main.ml"
+
+*libunix
+** setup-ocamlc.byte-build-env
+program = "${test_build_directory}/cloexec.byte"
+*** ocamlc.byte
+program = "${test_build_directory}/fdstatus.exe"
+all_modules = "fdstatus_aux.c fdstatus_main.ml"
+**** ocamlc.byte
+program = "${test_build_directory}/cloexec.byte"
+all_modules= "cloexec.ml"
+***** check-ocamlc.byte-output
+****** run
+******* check-program-output
+
+** setup-ocamlopt.byte-build-env
+program = "${test_build_directory}/cloexec.opt"
+*** ocamlopt.byte
+program = "${test_build_directory}/fdstatus.exe"
+all_modules = "fdstatus_aux.c fdstatus_main.ml"
+**** ocamlopt.byte
+program = "${test_build_directory}/cloexec.opt"
+all_modules= "cloexec.ml"
+***** check-ocamlopt.byte-output
+****** run
+******* check-program-output
+
+*)
+
(* This is a terrible hack that plays on the internal representation
of file descriptors. The result is a number (as a string)
that the fdstatus.exe auxiliary program can use to check whether
- the fd is open. *)
+ the fd is open. Moreover, since fdstatus.exe is an OCaml program,
+ we must take into account that the Windows OCaml runtime opens a few handles
+ for its own use, hence we do likewise to try to get handle numbers
+ Windows will not allocate to the OCaml runtime of fdstatus.exe *)
let string_of_fd (fd: Unix.file_descr) : string =
match Sys.os_type with
Int64.to_string (Obj.magic fd : int64)
| _ -> assert false
+let status_checker = "fdstatus.exe"
+
let _ =
let f0 = Unix.(openfile "tmp.txt" [O_WRONLY; O_CREAT; O_TRUNC] 0o600) in
+ let untested1 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
+ let untested2 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
+ let untested3 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
+ let untested4 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
+ let untested5 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
let f1 = Unix.(openfile "tmp.txt" [O_RDONLY; O_KEEPEXEC] 0) in
let f2 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
let d0 = Unix.dup f0 in
p0;p0';p1;p1';p2;p2';
s0;s1;s2;
x0;x0';x1;x1';x2;x2' |] in
+ let untested =
+ [untested1; untested2; untested3; untested4; untested5]
+ in
let pid =
Unix.create_process
- (Filename.concat Filename.current_dir_name "fdstatus.exe")
- (Array.append [| "fdstatus" |] (Array.map string_of_fd fds))
+ (Filename.concat Filename.current_dir_name status_checker)
+ (Array.append [| status_checker |] (Array.map string_of_fd fds))
Unix.stdin Unix.stdout Unix.stderr in
ignore (Unix.waitpid [] pid);
- Array.iter (fun fd -> try Unix.close fd with Unix.Unix_error _ -> ()) fds;
+ let close fd = try Unix.close fd with Unix.Unix_error _ -> () in
+ Array.iter close fds;
+ List.iter close untested;
Sys.remove "tmp.txt"
+++ /dev/null
-#include <stdio.h>
-
-int main (int argc, char *argv[])
-{
- int i;
- for (i = 1; i < argc; i ++) {
- printf ("%s\n", argv[i]);
- }
- return 0;
-}
--- /dev/null
+let () =
+ for i = 1 to (Array.length Sys.argv) - 1 do
+ Printf.printf "%s\n" Sys.argv.(i)
+ done
+(* TEST
+include unix
+*)
+
let _ =
let f = Unix.dup ~cloexec:true Unix.stdout in
let txt = "Some output\n" in
+(* TEST
+include unix
+stderr = "/dev/null"
+*)
+
let cat file =
let fd = Unix.openfile file [Unix.O_RDONLY] 0 in
let buf = Bytes.create 1024 in
+++ /dev/null
-/* Check if file descriptors are open or not */
-
-#include <stdio.h>
-#include <stdlib.h>
-
-#ifdef _WIN32
-
-#define WIN32_LEAN_AND_MEAN
-#include <wtypes.h>
-#include <winbase.h>
-#include <winerror.h>
-
-void process_fd(char * s)
-{
- int fd;
- HANDLE h;
- DWORD flags;
-
-#ifdef _WIN64
- h = (HANDLE) _atoi64(s);
-#else
- h = (HANDLE) atoi(s);
-#endif
- if (GetHandleInformation(h, &flags)) {
- printf("open\n");
- } else if (GetLastError() == ERROR_INVALID_HANDLE) {
- printf("closed\n");
- } else {
- printf("error %lu\n", (unsigned long)(GetLastError()));
- }
-}
-
-#else
-
-#include <limits.h>
-#include <string.h>
-#include <errno.h>
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <unistd.h>
-
-void process_fd(char * s)
-{
- long n;
- int fd;
- char * endp;
- struct stat st;
- n = strtol(s, &endp, 0);
- if (*endp != 0 || n < 0 || n > (long) INT_MAX) {
- printf("parsing error\n");
- return;
- }
- fd = (int) n;
- if (fstat(fd, &st) != -1) {
- printf("open\n");
- } else if (errno == EBADF) {
- printf("closed\n");
- } else {
- printf("error %s\n", strerror(errno));
- }
-}
-
-#endif
-
-int main(int argc, char ** argv)
-{
- int i;
- for (i = 1; i < argc; i++) {
- printf("#%d: ", i);
- process_fd(argv[i]);
- }
- return 0;
-}
--- /dev/null
+/* Check if file descriptors are open or not */
+
+#include <stdio.h>
+#include <stdlib.h>
+
+#ifdef _WIN32
+
+#define WIN32_LEAN_AND_MEAN
+#include <wtypes.h>
+#include <winbase.h>
+#include <winerror.h>
+
+void process_fd(char * s)
+{
+ int fd;
+ HANDLE h;
+ DWORD flags;
+
+#ifdef _WIN64
+ h = (HANDLE) _atoi64(s);
+#else
+ h = (HANDLE) atoi(s);
+#endif
+ if (GetHandleInformation(h, &flags)) {
+ printf("open\n");
+ } else if (GetLastError() == ERROR_INVALID_HANDLE) {
+ printf("closed\n");
+ } else {
+ printf("error %lu\n", (unsigned long)(GetLastError()));
+ }
+}
+
+#else
+
+#include <limits.h>
+#include <string.h>
+#include <errno.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+void process_fd(char * s)
+{
+ long n;
+ int fd;
+ char * endp;
+ struct stat st;
+ n = strtol(s, &endp, 0);
+ if (*endp != 0 || n < 0 || n > (long) INT_MAX) {
+ printf("parsing error\n");
+ return;
+ }
+ fd = (int) n;
+ if (fstat(fd, &st) != -1) {
+ printf("open\n");
+ } else if (errno == EBADF) {
+ printf("closed\n");
+ } else {
+ printf("error %s\n", strerror(errno));
+ }
+}
+
+#endif
+
+#include "caml/mlvalues.h"
+#include "caml/memory.h"
+
+CAMLprim value caml_process_fd(value CAMLnum, value CAMLfd)
+{
+ CAMLparam2(CAMLnum, CAMLfd);
+ printf("#%d: ", Int_val(CAMLnum));
+ process_fd(String_val(CAMLfd));
+ CAMLreturn(Val_unit);
+}
--- /dev/null
+external process_fd : int -> string -> unit = "caml_process_fd"
+
+let () =
+ for i = 1 to (Array.length Sys.argv) -1
+ do
+ process_fd i Sys.argv.(i);
+ done
--- /dev/null
+cloexec.ml
+dup2.ml
+dup.ml
+pipe_eof.ml
+redirections.ml
+rename.ml
+test_unix_cmdline.ml
+utimes.ml
+wait_nohang.ml
+(* TEST
+include unix
+*)
+
let drain pipe =
let max = 2048 in
let buf = Buffer.create 2048 in
+(* TEST
+
+files = "reflector.ml"
+
+* setup-ocamlc.byte-build-env
+program = "${test_build_directory}/redirections.byte"
+** ocamlc.byte
+program = "${test_build_directory}/reflector.exe"
+all_modules = "reflector.ml"
+*** ocamlc.byte
+include unix
+program = "${test_build_directory}/redirections.byte"
+all_modules= "redirections.ml"
+**** check-ocamlc.byte-output
+***** run
+****** check-program-output
+
+* setup-ocamlopt.byte-build-env
+program = "${test_build_directory}/redirections.opt"
+** ocamlopt.byte
+program = "${test_build_directory}/reflector.exe"
+all_modules = "reflector.ml"
+*** ocamlopt.byte
+include unix
+program = "${test_build_directory}/redirections.opt"
+all_modules= "redirections.ml"
+**** check-ocamlopt.byte-output
+***** run
+****** check-program-output
+
+*)
+
+
let cat file =
let fd = Unix.openfile file [Unix.O_RDONLY] 0 in
let buf = Bytes.create 1024 in
let refl =
Filename.concat Filename.current_dir_name "reflector.exe"
-let test_createprocess () =
+let test_createprocess systemenv =
let f_out =
Unix.(openfile "./tmpout.txt" [O_WRONLY;O_TRUNC;O_CREAT;O_CLOEXEC] 0o600) in
let f_err =
let pid =
Unix.create_process_env
refl
- [| refl; "i2o"; "i2e"; "o"; "123"; "e"; "456"; "i2o"; "v"; "XVAR" |]
- [| "XVAR=xvar" |]
+ [| refl; "-i2o"; "-i2e"; "-o"; "123"; "-e"; "456"; "-i2o"; "-v"; "XVAR" |]
+ (Array.append [| "XVAR=xvar" |] systemenv)
p_exit f_out f_err in
out p_entrance "aaaa\n";
out p_entrance "bbbb\n";
let pid =
Unix.create_process
refl
- [| refl; "o"; "123"; "e"; "456"; "o"; "789" |]
+ [| refl; "-o"; "123"; "-e"; "456"; "-o"; "789" |]
Unix.stdin Unix.stdout Unix.stdout in
let (_, status) = Unix.waitpid [] pid in
if status <> Unix.WEXITED 0 then
let pid =
Unix.create_process
refl
- [| refl; "e"; "123" |]
+ [| refl; "-e"; "123" |]
Unix.stdin Unix.stderr Unix.stdout in
let (_, status) = Unix.waitpid [] pid in
if status <> Unix.WEXITED 0 then
out Unix.stdout "!!! reflector exited with an error\n"
let test_open_process_in () =
- let ic = Unix.open_process_in (refl ^ " o 123 o 456") in
+ let ic = Unix.open_process_in (refl ^ " -o 123 -o 456") in
out Unix.stdout (input_line ic ^ "\n");
out Unix.stdout (input_line ic ^ "\n");
let status = Unix.close_process_in ic in
out Unix.stdout "!!! reflector exited with an error\n"
let test_open_process_out () =
- let oc = Unix.open_process_out (refl ^ " i2o i2o i2o") in
+ let oc = Unix.open_process_out (refl ^ " -i2o -i2o -i2o") in
output_string oc "aa\nbbbb\n"; close_out oc;
let status = Unix.close_process_out oc in
if status <> Unix.WEXITED 0 then
out Unix.stdout "!!! reflector exited with an error\n"
-let test_open_process_full () =
+let test_open_process_full systemenv =
let ((o, i, e) as res) =
Unix.open_process_full
- (refl ^ " o 123 i2o e 456 i2e v XVAR")
- [|"XVAR=xvar"|] in
+ (refl ^ " -o 123 -i2o -e 456 -i2e -v XVAR")
+ (Array.append [|"XVAR=xvar"|] systemenv) in
output_string i "aa\nbbbb\n"; close_out i;
for _i = 1 to 3 do
out Unix.stdout (input_line o ^ "\n")
out Unix.stdout "!!! reflector exited with an error\n"
let _ =
+ let ocamlrunparam =
+ match Sys.getenv_opt "OCAMLRUNPARAM" with
+ | None -> [||]
+ | Some v -> [|"OCAMLRUNPARAM=" ^ v|]
+ in
(* The following 'close' makes things more difficult.
Under Unix it works fine, but under Win32 create_process
gives an error if one of the standard handles is closed. *)
(* Unix.close Unix.stdin; *)
out Unix.stdout "** create_process\n";
- test_createprocess();
+ test_createprocess ocamlrunparam;
out Unix.stdout "** create_process 2>&1 redirection\n";
test_2ampsup1();
out Unix.stdout "** create_process swap 1-2\n";
out Unix.stdout "** open_process_out\n";
test_open_process_out();
out Unix.stdout "** open_process_full\n";
- test_open_process_full()
-
-
+ test_open_process_full ocamlrunparam
+++ /dev/null
-#include <stdio.h>
-#include <string.h>
-#include <stdlib.h>
-#if defined(_WIN32)
-#include <fcntl.h>
-#include <io.h>
-#endif
-
-/* A tool to read data from standard input and send it to standard
- output or standard error. */
-
-void copyline(FILE * in, FILE * out)
-{
- int c;
- do {
- c = getc(in);
- if (c == EOF) {
- fputs("<end of file>\n", out);
- break;
- }
- putc(c, out);
- } while (c != '\n');
- fflush(out);
-}
-
-/* Command language:
- i2o copy one line from stdin to stdout
- i2e copy one line from stdin to stderr
- o <txt> write <txt> plus newline to stdout
- e <txt> write <txt> plus newline to stderr
- v <var> write value of environment variable <env> to stdout
-*/
-
-int main(int argc, char ** argv)
-{
- int i;
- char * cmd;
-#if defined(_WIN32)
- _setmode(_fileno(stdin), _O_BINARY);
- _setmode(_fileno(stdout), _O_BINARY);
- _setmode(_fileno(stderr), _O_BINARY);
-#endif
- i = 1;
- while (i < argc) {
- cmd = argv[i];
- if (strcmp(cmd, "i2o") == 0) {
- copyline(stdin, stdout);
- i++;
- } else if (strcmp(cmd, "i2e") == 0) {
- copyline(stdin, stderr);
- i++;
- } else if (strcmp(cmd, "o") == 0 && i + 1 < argc) {
- fputs(argv[i + 1], stdout);
- fputc('\n', stdout);
- fflush(stdout);
- i += 2;
- } else if (strcmp(cmd, "e") == 0 && i + 1 < argc) {
- fputs(argv[i + 1], stderr);
- fputc('\n', stderr);
- fflush(stderr);
- i += 2;
- } else if (strcmp(cmd, "v") == 0 && i + 1 < argc) {
- char * v = getenv(argv[i + 1]);
- fputs((v == NULL ? "<no such variable>" : v), stdout);
- fputc('\n', stdout);
- fflush(stdout);
- i += 2;
- } else {
- fputs("<bad argument>\n", stderr);
- return 2;
- }
- }
- return 0;
-}
--- /dev/null
+let copyline input output =
+ let rec copy() = match input_char input with
+ | exception End_of_file ->
+ output_string output "<end of file>\n"
+ | char ->
+ output_char output char;
+ if char='\n' then () else copy()
+ in
+ copy();
+ flush output
+
+let output_endline output str =
+ output_string output str;
+ output_char output '\n';
+ flush output
+
+let output_env_var output env_var =
+ let value = match Sys.getenv_opt env_var with
+ | None -> "<no such variable>"
+ | Some v -> v
+ in
+ output_endline stdout value
+
+let options =
+[
+ ("-i2o",
+ Arg.Unit (fun () -> (copyline stdin stdout)),
+ "copy one line from stdin to stdout");
+ ("-i2e",
+ Arg.Unit (fun () -> (copyline stdin stderr)),
+ "copy one line from stdin to stderr");
+ ("-o",
+ Arg.String (output_endline stdout),
+ "-o <txt> write <txt> plus newline to stdout");
+ ("-e",
+ Arg.String (output_endline stderr),
+ "-e <txt> write <txt> plus newline to stderr");
+ ("-v",
+ Arg.String (output_env_var stdout),
+ "-v <var> write value of environment variable <env> to stdout");
+]
+
+let report_bad_argument _arg =
+ output_endline stderr "<bad argument>"
+
+let () =
+ set_binary_mode_in stdin true;
+ set_binary_mode_out stdout true;
+ set_binary_mode_out stderr true;
+ Arg.parse options report_bad_argument ""
+
\ No newline at end of file
+(* TEST
+include unix
+*)
+
(* Test the Unix.rename function *)
let writefile filename contents =
+(* TEST
+
+files = "cmdline_prog.ml"
+
+* setup-ocamlc.byte-build-env
+program = "${test_build_directory}/test_unix_cmdline.byte"
+** ocamlc.byte
+program = "${test_build_directory}/cmdline_prog.exe"
+all_modules = "cmdline_prog.ml"
+*** ocamlc.byte
+include unix
+program = "${test_build_directory}/test_unix_cmdline.byte"
+all_modules= "test_unix_cmdline.ml"
+**** check-ocamlc.byte-output
+***** run
+****** check-program-output
+
+* setup-ocamlopt.byte-build-env
+program = "${test_build_directory}/test_unix_cmdline.opt"
+** ocamlc.byte
+program = "${test_build_directory}/cmdline_prog.exe"
+all_modules = "cmdline_prog.ml"
+*** ocamlopt.byte
+include unix
+program = "${test_build_directory}/test_unix_cmdline.opt"
+all_modules= "test_unix_cmdline.ml"
+**** check-ocamlopt.byte-output
+***** run
+****** check-program-output
+
+*)
+
open Unix
let prog_name = "cmdline_prog.exe"
--- /dev/null
+(* TEST
+include unix
+files = "utimes.txt"
+*)
+
+(* We do not check setting the "last access time" because it is hard to do so on
+ some file systems. FAT, for example, only has a 1d resolution for this
+ timestamp, and even NTFS can potentially delay the update of this timestamp
+ by up to an hour.
+*)
+
+let txt = "utimes.txt"
+
+(* To account for filesystems with large timestamp resolution (e.g. FAT - 2
+ seconds for mtime)
+*)
+let close s t =
+ abs_float (s -. t) < 10.
+
+let check tm =
+ let tm' = (Unix.stat txt).Unix.st_mtime in
+ Printf.printf "tm ~ tm' (%B)\n" (close tm tm')
+
+let () =
+ let oc = open_out_bin txt in
+ close_out oc;
+ let tm = 1508391026.124 in
+ Unix.utimes txt tm tm;
+ check tm;
+ let tn = Unix.time () in
+ Unix.utimes txt 0. 0.;
+ check tn
--- /dev/null
+tm ~ tm' (true)
+tm ~ tm' (true)
+(* TEST
+include unix
+*)
+
let () =
let fd = Unix.openfile "plop" [O_CREAT; O_WRONLY] 0o666 in
let pid =
+++ /dev/null
-BASEDIR=../../..
-LIBRARIES=unix
-ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-MAIN_MODULE=isatty
-PROGRAM_ARGS=2>/dev/null </dev/null
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+include unix
+stdin = "/dev/null"
+stderr = "/dev/null"
+*)
+
Printf.printf
"Unix.isatty Unix.stdin = %b\n\
Unix.isatty Unix.stdout = %b\n\
+(* TEST
+
+* libwin32unix
+include unix
+** bytecode
+** native
+
+*)
+
let console =
try
Unix.(openfile "/dev/tty" [O_RDWR] 0)
+++ /dev/null
-test "$TOOLCHAIN" = "msvc" || test "$TOOLCHAIN" = "mingw"
--- /dev/null
+isatty_std.ml
+isatty_tty.ml
+++ /dev/null
-BASEDIR=../../..
-LIBRARIES=unix
-ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-MAIN_MODULE=exec
-
-test:
- @if grep -q HAS_EXECVPE $(OTOPDIR)/byterun/caml/s.h; \
- then echo " ... testing => skipped (using the system-provided execvpe())"; \
- else $(MAKE) compile && $(SET_LD_PATH) $(MAKE) myrun; \
- fi
-
-myrun:
- @printf " ... testing with"
- @if $(NATIVECODE_ONLY); then : ; else \
- printf " ocamlc"; \
- ./exec.run "$(MYRUNTIME) ./program.byte$(EXE)" $(EXEC_ARGS) \
- >$(MAIN_MODULE).result \
- && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result \
- >/dev/null; \
- fi \
- && if $(BYTECODE_ONLY); then : ; else \
- printf " ocamlopt"; \
- ./exec.run ./program.native$(EXE) $(EXEC_ARGS) \
- > $(MAIN_MODULE).result \
- && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result \
- >/dev/null; \
- fi \
- && echo " => passed" || echo " => failed"
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ include unix
+ script = "sh ${test_source_directory}/has-execvpe.sh"
+ * script
+ ** bytecode
+ ** native
+*)
+
open Printf
let _ =
#!/bin/sh
-program=$1
-if test -z "$program"; then echo "Usage: exec.run <program>" 1&>2; exit 2; fi
+if test -z "$program"; then echo "Define the program env var" 1&>2; exit 2; fi
-exec 2>&1
+output=$program.output
+exec > ${output} 2>&1
-export PATH="/bin:/usr/bin:./subdir:"
+subdir=${test_source_directory}/subdir
+
+# Let ocamltest know where we write our output
+echo output=\"${output}\" > ${ocamltest_response}
+
+export PATH="/bin:/usr/bin:${subdir}:"
export BAR=bar
echo "## Test 1: a binary program in the path"
echo "## Test 3: a script without #! in the path"
$program script2 5 6 7 || echo "script2 failed"
echo "## Test 4: a script in the current directory"
+cd ${test_source_directory}
$program script3 8 9 || echo "script3 failed"
echo "## Test 5: a non-existent program"
$program nosuchprogram
echo "## Test 6: a non-executable program"
$program nonexec
-export PATH="/bin:/usr/bin:./subdir"
+export PATH="/bin:/usr/bin:${subdir}"
echo "## Test 7: a script in the current directory"
$program script3 9 && echo "script3 should have failed"
exit 0
--- /dev/null
+#!/bin/sh
+
+# This script is related to the 'exec.ml' test.
+# It tests whether the OS implements execvpe or not.
+# It makes sense to run the tests only if execvpe is nt implemented.
+# If it is implemented, the test is skipped.
+
+if grep -q HAS_EXECVPE ${ocamlsrcdir}/byterun/caml/s.h; then
+ exit ${TEST_SKIP};
+fi
+exit ${TEST_PASS}
+++ /dev/null
-BASEDIR=../../..
-LIBRARIES=unix
-ADD_COMPFLAGS= \
- -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
- -strict-sequence -safe-string -w A -warn-error A
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-C_FILES=stubs
-
-.PHONY: test
-test:
- @if echo 'let () = exit (if Sys.win32 then 0 else 1)' | $(OCAML) -stdin; then \
- $(MAKE) check; \
- else \
- $(MAKE) SKIP=true C_FILES= run-all; \
- fi
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+test_env.ml
#include <windows.h>
-CAMLprim value caml_SetEnvironmentVariable(value s1, value s2)
+CAMLprim value stub_SetEnvironmentVariable(value s1, value s2)
{
WCHAR *w1, *w2;
w1 = caml_stat_strdup_to_utf16(String_val(s1));
-external set_environment_variable: string -> string -> unit = "caml_SetEnvironmentVariable"
+(* TEST
+include unix
+flags += "-strict-sequence -safe-string -w A -warn-error A"
+modules = "stubs.c"
+* libwin32unix
+** bytecode
+** native
+*)
+
+external set_environment_variable: string -> string -> unit = "stub_SetEnvironmentVariable"
let find_env s =
let env = Unix.environment () in
| Some s ->
Printf.printf "%s -> Some %S\n%!" title s
-let foo = "FOO"
-
let () =
- set_environment_variable foo "BAR";
- print "Sys.getenv FOO" (Sys.getenv_opt foo);
- print "Unix.environment FOO" (find_env foo)
+ set_environment_variable "FOO" "BAR";
+ Unix.putenv "FOO2" "BAR2";
+ print "Sys.getenv FOO" (Sys.getenv_opt "FOO");
+ print "Unix.environment FOO" (find_env "FOO");
+ print "Sys.getenv FOO2" (Sys.getenv_opt "FOO2")
-Sys.getenv FOO -> None
-Unix.environment FOO -> None
+Sys.getenv FOO -> Some "BAR"
+Unix.environment FOO -> Some "BAR"
+Sys.getenv FOO2 -> Some "BAR2"
+++ /dev/null
-(* This test is disabled (see test_env2.precheck) as it fails due to MPR#4499:
- the Windows POSIX environment does not get updated when using the native
- Windows API SetEnvironmentVariable. *)
-
-external set_environment_variable: string -> string -> unit = "caml_SetEnvironmentVariable"
-
-let print title = function
- | None ->
- Printf.printf "%s -> None\n%!" title
- | Some s ->
- Printf.printf "%s -> Some %S\n%!" title s
-
-let foo = "FOO"
-
-let () =
- set_environment_variable foo "BAR";
- print "Sys.getenv FOO" (Sys.getenv_opt foo)
+++ /dev/null
-# test_env2.ml disabled because it fails due to the fact that
-# Windows POSIX environment is not updated when using the native
-# API SetEnvironmentVariable (see MPR#4499)
-exit 1
+++ /dev/null
-Sys.getenv FOO -> Some "BAR"
+++ /dev/null
-BASEDIR=../../..
-LIBRARIES=unix
-ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-C_FILES=fakeclock
-MAIN_MODULE=test
-TEST_TEMP_FILES=dst-file non-dst-file
-
-ifeq ($(OS),Windows_NT)
-test:
- @TZ=utc touch -m -t 201707011200 dst-file
- @TZ=utc touch -m -t 201702011200 non-dst-file
- @$(MAKE) default
-else
-skip:
- @echo " ... testing => skipped (not on Windows)"
-endif
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+include unix
+modules = "fakeclock.c"
+* windows
+** bytecode
+** native
+*)
+
open Unix
external set_fake_clock : int64 -> unit = "set_fake_clock"
--- /dev/null
+#!/bin/sh
+TZ=utc touch -m -t 201707011200 dst-file
+TZ=utc touch -m -t 201702011200 non-dst-file
+`cygpath -m "${program}"` > `cygpath -m "${output}"` 2>&1
+++ /dev/null
-BASEDIR=../../..
-LIBRARIES=unix
-ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-MAIN_MODULE=test
-TEST_TEMP_FILES=link1 link2 test.txt
-
-test:
- @if $(OCAML) $(ADD_COMPFLAGS) unix.cma precheck.ml; then \
- $(MAKE) default; \
- else \
- echo " ... testing => skipped (not on Windows and/or symlinks not allowed)"; \
- fi
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+++ /dev/null
-let () =
- exit (if Sys.win32 && Unix.has_symlink () then 0 else 1)
+(* TEST
+
+ include unix
+* windows
+** has_symlink
+*** bytecode
+*** native
+
+*)
+
let link1 = "link1"
let link2 = "link2"
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Thomas Refis, Jane Street Europe *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* Copyright 2016 Jane Street Group LLC *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-default:
- @$(MAKE) byte
- @if $(BYTECODE_ONLY) ; then \
- echo " ... testing native 'test.reference': => skipped"; \
- else \
- $(MAKE) native; \
- fi
-
-native:
- @printf " ... testing native 'test.reference':"
- @$(OCAMLOPT) -c submodule.ml
- @$(OCAMLOPT) -c aliases.ml
- @$(OCAMLOPT) -c external.mli external.ml
- @$(OCAMLOPT) -c external_for_pack.mli external_for_pack.ml
- @$(OCAMLOPT) -c test.ml
- @$(OCAMLOPT) -a submodule.cmx aliases.cmx external.cmx \
- external_for_pack.cmx -o mylib.cmxa
- @$(OCAMLOPT) -c -for-pack P use_in_pack.ml
- @$(OCAMLOPT) -pack use_in_pack.cmx -o p.cmx
- @$(OCAMLOPT) mylib.cmxa p.cmx test.cmx -o test.native
- @./test.native > test.result
- @$(DIFF) test.result test.reference >/dev/null \
- && echo " => passed" || echo " => failed"
-
-byte:
- @printf " ... testing byte 'test.reference':"
- @$(OCAMLC) -c submodule.ml
- @$(OCAMLC) -c aliases.ml
- @$(OCAMLC) -c external.mli external.ml
- @$(OCAMLC) -c external_for_pack.mli external_for_pack.ml
- @$(OCAMLC) -c test.ml
- @$(OCAMLC) -a submodule.cmo aliases.cmo external.cmo \
- external_for_pack.cmo -o mylib.cma
- @$(OCAMLC) -c -for-pack P use_in_pack.ml
- @$(OCAMLC) -pack use_in_pack.cmo -o p.cmo
- @$(OCAMLC) mylib.cma p.cmo test.cmo -o test.byte
- @$(OCAMLRUN) ./test.byte > test.result
- @$(DIFF) test.result test.reference >/dev/null \
- && echo " => passed" || echo " => failed"
-
-promote: defaultpromote
-
-clean: defaultclean
- @rm -f *.result
- @rm -f test.native test.byte
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.common
-COMPFLAGS = -no-alias-deps
+(* TEST
+
+modules = "aliases.ml external_for_pack.ml external.ml submodule.ml test.ml use_in_pack.ml"
+
+* setup-ocamlc.byte-build-env
+program = "${test_build_directory}/test.byte"
+** ocamlc.byte
+module = "submodule.ml"
+flags = "-no-alias-deps"
+*** ocamlc.byte
+module = "aliases.ml"
+**** ocamlc.byte
+module = "external.mli"
+***** ocamlc.byte
+module = "external.ml"
+****** ocamlc.byte
+module = "external_for_pack.mli"
+******* ocamlc.byte
+module = "external_for_pack.ml"
+******** ocamlc.byte
+module = "test.ml"
+********* ocamlc.byte
+module = ""
+flags = "-a -no-alias-deps"
+all_modules = "submodule.cmo aliases.cmo external.cmo external_for_pack.cmo"
+program = "mylib.cma"
+********** ocamlc.byte
+flags = "-no-alias-deps -for-pack P"
+module = "use_in_pack.ml"
+*********** ocamlc.byte
+module = ""
+program = "p.cmo"
+flags = "-no-alias-deps -pack"
+all_modules = "use_in_pack.cmo"
+************ ocamlc.byte
+program = "${test_build_directory}/test.byte"
+all_modules = "mylib.cma p.cmo test.cmo"
+flags= "-no-alias-deps"
+************* check-ocamlc.byte-output
+************** run
+*************** check-program-output
+
+* setup-ocamlopt.byte-build-env
+program = "${test_build_directory}/test.opt"
+** ocamlopt.byte
+module = "submodule.ml"
+flags = "-no-alias-deps"
+*** ocamlopt.byte
+module = "aliases.ml"
+**** ocamlopt.byte
+module = "external.mli"
+***** ocamlopt.byte
+module = "external.ml"
+****** ocamlopt.byte
+module = "external_for_pack.mli"
+******* ocamlopt.byte
+module = "external_for_pack.ml"
+******** ocamlopt.byte
+module = "test.ml"
+********* ocamlopt.byte
+module = ""
+flags = "-no-alias-deps -a"
+all_modules = "submodule.cmx aliases.cmx external.cmx external_for_pack.cmx"
+program = "mylib.cmxa"
+********** ocamlopt.byte
+flags = "-no-alias-deps -for-pack P"
+module = "use_in_pack.ml"
+*********** ocamlopt.byte
+module = ""
+program = "p.cmx"
+flags = "-no-alias-deps -pack"
+all_modules = "use_in_pack.cmx"
+************ ocamlopt.byte
+program = "${test_build_directory}/test.opt"
+all_modules = "mylib.cmxa p.cmx test.cmx"
+flags = "-no-alias-deps"
+************* check-ocamlopt.byte-output
+************** run
+*************** check-program-output
+
+*)
+
include Aliases.Submodule.M
let _, _ = External.frexp 3.
+++ /dev/null
-# Tests from manual, section intf-c
-# main.ml: error message when equality is missing
-# main_ok.ml: allow path expansion even when the target is missing (GPR#816)
-
-SOURCES = curses.ml prog.ml
-CSOURCES = curses_stubs.c
-CLIBS = -cclib "$(BYTECCLIBS)"
-LIBUNIX = -I $(BASEDIR)/../otherlibs/unix unix.cma
-
-# Disable this test until we figure out how to test for the availability
-# of curses.
-.PHONY: disable
-disable:
- @printf " ... testing prog => skipped\n"
- @printf " ... testing prog2 => skipped\n"
-
-.PHONY: default
-default: clean $(SOURCES) $(CSOURCES)
- @printf " ... testing prog"
- @$(MAKE) prog > /dev/null && echo " => passed" || echo " => failed"
- @printf " ... testing prog2"
- @$(MAKE) prog2 REDIRECT=">prog2.result 2>&1" \
- >/dev/null 2>/dev/null || :
- @$(DIFF) prog2.reference prog2.result >/dev/null \
- && echo " => passed" || echo " => failed"
-
-# Should succeed
-prog:
- $(OCAMLC) -custom -o prog $(LIBUNIX) $(SOURCES) $(CSOURCES) $(CLIBS)
-
-# Should fail
-prog2: curses.cmo
- $(OCAMLC) -custom -o prog2 $(LIBUNIX) prog.ml $(CSOURCES) $(CLIBS) $(REDIRECT)
-
-.PHONY: clean
-clean:
- @rm -f *.cm* *.o *~ prog prog2
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+(* Tests from manual, section intf-c *)
+(*
+ This test is currently skipped because there is no proper way to
+ figure out whether Curses is avaiblable or not. If it becomes possible
+ to figure that out, it would be nice to be able to check that the test
+ compiles. Executing seems lessrelevant.
+*)
+* skip
+reason = "curses can not be properly detected at the moment"
+*)
+
(* File prog.ml -- main program using curses *)
open Curses;;
let main_window = initscr () in
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * toplevel
+*)
+
(** Test exhaustiveness.
match clauses should continue to give warnings about inexhaustive
--- /dev/null
+Characters 236-315:
+ ....match None with
+ | exception e -> ()
+ | Some false -> ()
+ | None -> ()
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some true
+val test_match_exhaustiveness : unit -> unit = <fun>
+
--- /dev/null
+exhaustiveness_warnings.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
(** Test that matching multiple values doesn't allocate a block. *)
let f x y =
+(* TEST
+*)
+
(**
Test that match allows exceptions to propagate.
*)
+(* TEST
+*)
+
(**
Test that value match failure in a match block raises Match_failure.
*)
+(* TEST
+*)
+
(*
Test that multiple handlers coexist happily.
*)
--- /dev/null
+allocation.ml
+exception_propagation.ml
+match_failure.ml
+nested_handlers.ml
+raise_from_success_continuation.ml
+streams.ml
+tail_calls.ml
+(* TEST
+*)
+
(**
Test raising exceptions from a value-matching branch.
*)
+(* TEST
+*)
+
(**
Test the stream example .
*)
+(* TEST
+*)
+
(**
The success continuation expression is in tail position.
*)
+++ /dev/null
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.expect
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+precise_locations.ml
+(* TEST
+ * expect
+*)
+
type t = (unit, unit, unit, unit) bar
;;
(* PR#7315: we expect the error location on "bar" instead of "(...) bar" *)
[%%expect{|
Line _, characters 34-37:
+ type t = (unit, unit, unit, unit) bar
+ ^^^
Error: Unbound type constructor bar
|}];;
(* we expect the location on "bar" instead of "#bar" *)
[%%expect{|
Line _, characters 1-4:
+ #bar) -> ();;
+ ^^^
Error: Unbound class bar
|}];;
(* we expect the location on "bar" instead of "#bar" *)
[%%expect{|
Line _, characters 1-4:
+ #bar -> ()
+ ^^^
Error: Unbound type constructor bar
|}];;
(* we expect the location on "bar" instead of "new bar" *)
[%%expect{|
Line _, characters 4-7:
+ new bar;;
+ ^^^
Error: Unbound class bar
|}];;
[%%expect{|
type t = Foo of unit | Bar
Line _, characters 0-6:
+ Foo ();;
+ ^^^^^^
Error (warning 3): deprecated: Foo
|}];;
function
(* "Foo _", the whole construct is deprecated *)
[%%expect{|
Line _, characters 0-5:
+ Foo _ -> () | Bar -> ();;
+ ^^^^^
Error (warning 3): deprecated: Foo
|}];;
(* the error location should be on "Foo" *)
[%%expect{|
Line _, characters 5-8:
+ open Foo;;
+ ^^^
Error: Unbound module Foo
|}];;
on "open List" as whole rather than "List" *)
[%%expect{|
Line _, characters 0-9:
-Error (warning 33): unused open List.
+ open List
+ ^^^^^^^^^
+Error (warning 33): unused open Stdlib.List.
|}];;
type unknown += Foo;;
(* unknown, not the whole line *)
[%%expect{|
Line _, characters 5-12:
+ type unknown += Foo;;
+ ^^^^^^^
Error: Unbound type constructor unknown
|}];;
[%%expect{|
type t = ..
Line _, characters 6-12:
+ Foo = Foobar;;
+ ^^^^^^
Error: Unbound constructor Foobar
|}];;
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-MODULES=terms equations orderings kb
-MAIN_MODULE=kbmain
-ADD_COMPFLAGS=-w a
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ modules = "terms.ml equations.ml orderings.ml kb.ml"
+*)
+
open Terms
open Equations
open Orderings
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-UNSAFE=ON
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ flags += " -unsafe "
+*)
+
(*
* ALMABENCH 1.0.1
* OCaml version
+(* TEST
+ flags += " -unsafe "
+*)
+
let pi = 3.14159265358979323846
let tpi = 2.0 *. pi
--- /dev/null
+almabench.ml
+fft.ml
+quicksort.ml
+soli.ml
+(* TEST
+ flags += " -unsafe "
+*)
+
(* Good test for loops. Best compiled with -unsafe. *)
let rec qsort lo hi (a : int array) =
+(* TEST
+ flags += " -unsafe "
+*)
+
type peg = Out | Empty | Peg
let board = [|
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
(* Translated to OCaml by Xavier Leroy *)
(* Original code written in SML by ... *)
+(* TEST
+*)
+
(* Manipulations over terms *)
type term =
+(* TEST
+*)
+
let debug = false
open Printf
+(* TEST
+*)
+
(***
This test evaluate boolean formula composed by conjunction and
disjunction using ephemeron:
+(* TEST
+*)
+
(** This test weak table by application to the memoization of collatz
(also known as syracuse) algorithm suite computation *)
+(* TEST
+*)
+
let rec fib n =
if n < 2 then 1 else fib(n-1) + fib(n-2)
-
+(* TEST
+*)
let m = 1000
let m' = 100
+(* TEST
+*)
+
type t = Leaf of int | Branch of t * t
type floatref = { mutable f : float }
--- /dev/null
+(* TEST
+*)
+
+type t = A|B|C|D
+type s =
+ | G of t
+ | E of t
+ | H of t
+ | F of (unit list * t)
+ | I of t
+
+let r = ref 0
+
+let set x = r := x
+
+let f x =
+ match x with
+ | E B | F ([()], B) -> set 0
+ | E x | F ([()], x) when Sys.opaque_identity true -> set 1
+ | E _ -> set 2
+ | F _ -> set 3
+ | G _ | H _ | I _ -> set 4
+(* TEST
+*)
+
(* We cannot use bignums because we don't do custom runtimes, but
int64 is a bit short, so we roll our own 37-digit numbers...
*)
+(* TEST
+*)
+
(* Use floating-point arithmetic *)
external (+) : float -> float -> float = "%addfloat"
--- /dev/null
+bdd.ml
+boyer.ml
+ephetest.ml
+ephetest2.ml
+ephetest3.ml
+fib.ml
+finaliser.ml
+gcwords.ml
+gpr1370.ml
+hamming.ml
+nucleic.ml
+pr7168.ml
+sieve.ml
+sorts.ml
+takc.ml
+taku.ml
+weaklifetime.ml
+weaklifetime2.ml
+weaktest.ml
+(* TEST
+*)
+
let rec f x =
let x = x+x in let x = x+x in let x = x+x in let x = x+x in
let x = x+x in let x = x+x in let x = x+x in let x = x+x in
+(* TEST
+*)
+
(* Eratosthene's sieve *)
(* interval min max = [min; min+1; ...; max-1; max] *)
+(* TEST
+*)
+
(* Test bench for sorting algorithms. *)
+(* TEST
+*)
+
let rec tak x y z =
if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y)
else z
+(* TEST
+*)
+
let rec tak (x, y, z) =
if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
else z
+(* TEST
+*)
+
Random.init 12345;;
let size = 1000;;
+(* TEST
+*)
+
let n = 500
let loop = 2
+(* TEST
+*)
+
let debug = false;;
open Printf;;
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-default: b.cmi c.cmi d.cmi aliases.ml
- @$(OCAMLC) -c aliases.ml > aliases.ml.result 2>&1 || true
- @$(OBJINFO) aliases.cmo | \
- sed -e "s/[a-f0-9]\{32\}/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/g" \
- > aliases.cmo.result 2>&1 || true
- @for file in *.reference; do \
- printf " ... testing '$$file':"; \
- $(DIFF) $$file `basename $$file reference`result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done
-
-promote: defaultpromote
-
-clean: defaultclean
- @rm -f *.result
-
-b.cmi: b.cmi.pre
- @cp b.cmi.pre b.cmi
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.common
-COMPFLAGS = -no-alias-deps
+++ /dev/null
-File aliases.cmo
-Unit name: Aliases
-Interfaces imported:
- aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa Pervasives
- aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa D
- aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa CamlinternalFormatBasics
- -------------------------------- C
- -------------------------------- B
- aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa Aliases
- -------------------------------- A
-Required globals:
- D
- Pervasives
-Uses unsafe features: no
-Force link: no
--- /dev/null
+File "aliases.ml", line 16, characters 12-13:
+Warning 49: no cmi file was found in path for module A
+File "aliases.ml", line 17, characters 12-13:
+Warning 49: no valid cmi file was found in path for module B. b.cmi
+is not a compiled interface
+(* TEST
+flags = "-no-alias-deps"
+compile_only = "true"
+files = "c.mli d.mli"
+* setup-ocamlc.byte-build-env
+** script
+script = "cp ${test_source_directory}/b.cmi.invalid ${test_build_directory}/b.cmi"
+*** ocamlc.byte
+all_modules = "c.mli d.mli aliases.ml"
+**** check-ocamlc.byte-output
+***** ocamlobjinfo
+program = "aliases.cmo"
+****** check-program-output
+*)
+
module A' = A (* missing a.cmi *)
module B' = B (* broken b.cmi *)
module C' = C (* valid c.cmi *)
+++ /dev/null
-File "_none_", line 1:
-Warning 49: no cmi file was found in path for module A
-File "_none_", line 1:
-Warning 49: no valid cmi file was found in path for module B. b.cmi
-is not a compiled interface
--- /dev/null
+File aliases.cmo
+Unit name: Aliases
+Interfaces imported:
+ 00000000000000000000000000000000 Stdlib
+ 00000000000000000000000000000000 D
+ 00000000000000000000000000000000 CamlinternalFormatBasics
+ -------------------------------- C
+ -------------------------------- B
+ 00000000000000000000000000000000 Aliases
+ -------------------------------- A
+Required globals:
+ D
+ Stdlib
+Uses unsafe features: no
+Force link: no
--- /dev/null
+Not a valid cmi file
+++ /dev/null
-Not a valid cmi file
--- /dev/null
+aliases.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-
-.PHONY: default
-default:
- @if $(BYTECODE_ONLY); then $(MAKE) skip ; else \
- $(MAKE) compile; \
- fi
-
-.PHONY: skip
-skip:
- @echo " ... testing 'test' with ordinary compilation => skipped"
- @echo " ... testing 'test' with change to opaque interface => skipped"
- @echo " ... testing 'test' with change to opaque implementation \
- => skipped"
- @echo " ... testing 'test' with change to non-opaque implementation \
- => skipped"
-
-.PHONY: compile
-compile:
- @$(OCAMLOPT) -I intf -opaque -c intf/opaque_intf.mli
- @$(OCAMLOPT) -I intf -c intf/opaque_impl.mli
- @$(OCAMLOPT) -I intf -c intf/regular.mli
- @cp intf/*.mli intf/*.cmi fst
- @cp intf/*.mli intf/*.cmi snd
- @$(OCAMLOPT) -I fst -c fst/opaque_intf.ml
- @$(OCAMLOPT) -I fst -opaque -c fst/opaque_impl.ml
- @$(OCAMLOPT) -I fst -c fst/regular.ml
- @$(OCAMLOPT) -I snd -c snd/opaque_intf.ml
- @$(OCAMLOPT) -I snd -opaque -c snd/opaque_impl.ml
- @$(OCAMLOPT) -I snd -c snd/regular.ml
- @$(OCAMLOPT) -I fst -c test.ml
- @
- @printf " ... testing 'test' with ordinary compilation"; \
- $(OCAMLOPT) fst/opaque_intf.cmx fst/opaque_impl.cmx \
- fst/regular.cmx test.cmx 2>/dev/null \
- && echo " => passed" || echo " => failed"; \
- printf " ... testing 'test' with change to opaque interface"; \
- $(OCAMLOPT) snd/opaque_intf.cmx fst/opaque_impl.cmx \
- fst/regular.cmx test.cmx 2>/dev/null \
- && echo " => passed" || echo " => failed"; \
- printf " ... testing 'test' with change to opaque implementation"; \
- $(OCAMLOPT) fst/opaque_intf.cmx snd/opaque_impl.cmx \
- fst/regular.cmx test.cmx 2>/dev/null \
- && echo " => passed" || echo " => failed"; \
- printf " ... testing 'test' with change to non-opaque implementation";\
- $(OCAMLOPT) fst/opaque_intf.cmx fst/opaque_impl.cmx \
- snd/regular.cmx test.cmx 2>/dev/null \
- && echo " => failed" || echo " => passed"; \
-
-.PHONY: promote
-promote:
-
-.PHONY: clean
-clean: defaultclean
- @rm -f *.cmi *.cmx *.$(O) a.out camlprog.exe
- @rm -f intf/*.cmi
- @rm -f fst/*.cmi fst/*.cmx fst/*.$(O) fst/*.mli
- @rm -f snd/*.cmi snd/*.cmx snd/*.$(O) snd/*.mli
-
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+
+compile_only = "true"
+
+* setup-ocamlopt.byte-build-env
+** script
+script = "cp -r ${test_source_directory}/fst ${test_source_directory}/intf ${test_source_directory}/snd ${test_build_directory}"
+*** ocamlopt.byte
+flags = "-I intf -opaque"
+all_modules = "intf/opaque_intf.mli"
+**** ocamlopt.byte
+flags = "-I intf"
+all_modules = "intf/opaque_impl.mli intf/regular.mli"
+***** script
+script = "cp intf/opaque_intf.cmi intf/opaque_impl.cmi intf/regular.cmi intf/opaque_intf.mli intf/opaque_impl.mli intf/regular.mli fst"
+****** script
+script = "cp intf/opaque_intf.cmi intf/opaque_impl.cmi intf/regular.cmi intf/opaque_intf.mli intf/opaque_impl.mli intf/regular.mli snd"
+******* ocamlopt.byte
+flags = "-I fst -opaque"
+all_modules = "fst/opaque_impl.ml"
+******** ocamlopt.byte
+flags = "-I snd -opaque"
+all_modules = "snd/opaque_impl.ml"
+********* ocamlopt.byte
+flags = "-I fst"
+all_modules = "fst/opaque_intf.ml fst/regular.ml"
+********** ocamlopt.byte
+flags = "-I snd"
+all_modules = "snd/opaque_intf.ml snd/regular.ml"
+*********** ocamlopt.byte
+flags = "-I fst"
+all_modules = "test.ml"
+
+(* ordinary compilation *)
+************ ocamlopt.byte
+compile_only = "false"
+all_modules = "fst/opaque_intf.cmx fst/opaque_impl.cmx fst/regular.cmx test.cmx"
+program = "${test_build_directory}/p1.exe"
+
+(* change to opaque interface *)
+************ ocamlopt.byte
+compile_only = "false"
+all_modules = "snd/opaque_intf.cmx fst/opaque_impl.cmx fst/regular.cmx test.cmx"
+program = "${test_build_directory}/p2.exe"
+
+(* change to opaque implementation *)
+************ ocamlopt.byte
+compile_only = "false"
+all_modules = "fst/opaque_intf.cmx snd/opaque_impl.cmx fst/regular.cmx test.cmx"
+program = "${test_build_directory}/p3.exe"
+
+(* change to non-opaque implementation *)
+************ ocamlopt.byte
+compile_only = "false"
+all_modules = "fst/opaque_intf.cmx fst/opaque_impl.cmx snd/regular.cmx test.cmx"
+program = "${test_build_directory}/p4.exe"
+ocamlopt_byte_exit_status = "2"
+
+*)
let () =
print_endline (Opaque_intf.choose "Opaque_intf: First" "Opaque_intf: Second")
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-COMPFLAGS=-I $(OTOPDIR)/parsing
-MODULES=
-MAIN_MODULE=test
-LIBRARIES=../../../compilerlibs/ocamlcommon
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
(module type of[@foo] M) ->
(sig[@foo] end)
+module type S = S -> S -> S
+module type S = (S -> S) -> S
+module type S = functor (M : S) -> S -> S
+module type S = (functor (M : S) -> S) -> S
+module type S = (S -> S)[@foo] -> S
+module type S = (functor[@foo] (M : S) -> S) -> S
+
+module type S = sig
+ module rec A : (S with type t = t)
+ and B : (S with type t = t)
+end
+
(* Structure items *)
let%foo[@foo] x = 4
and[@foo] y = x
h.Def.%{"three"} <- 3
let x,y,z = Def.(h.%["one"], h.%("two"), h.%{"three"})
end
+
+type t = |
+(* TEST
+ include ocamlcommon
+ files = "source.ml"
+*)
+
(* (c) Alain Frisch / Lexifi *)
(* cf. PR#7200 *)
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Jeremie Dimino, Jane Street Europe *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-TOPFLAGS+=-dparsetree
-include $(BASEDIR)/makefiles/Makefile.dparsetree
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+[
+ structure_item (attributes.ml[8,120+0]..[8,120+8])
+ Pstr_attribute "foo"
+ []
+ structure_item (attributes.ml[10,130+0]..[11,169+9])
+ Pstr_value Nonrec
+ [
+ <def>
+ attribute "foo"
+ []
+ pattern (attributes.ml[10,130+4]..[10,130+38]) ghost
+ Ppat_constraint
+ pattern (attributes.ml[10,130+4]..[10,130+13])
+ attribute "foo"
+ []
+ Ppat_var "x" (attributes.ml[10,130+5]..[10,130+6])
+ core_type (attributes.ml[10,130+16]..[10,130+20])
+ attribute "foo"
+ []
+ Ptyp_constr "unit" (attributes.ml[10,130+16]..[10,130+20])
+ []
+ expression (attributes.ml[10,130+30]..[10,130+32])
+ attribute "foo"
+ []
+ Pexp_construct "()" (attributes.ml[10,130+30]..[10,130+32])
+ None
+ ]
+ structure_item (attributes.ml[13,180+0]..[15,217+7])
+ Pstr_type Rec
+ [
+ type_declaration "t" (attributes.ml[13,180+5]..[13,180+6]) (attributes.ml[13,180+0]..[15,217+7])
+ attribute "foo"
+ []
+ ptype_params =
+ []
+ ptype_cstrs =
+ []
+ ptype_kind =
+ Ptype_variant
+ [
+ (attributes.ml[14,189+2]..[14,189+27])
+ "Foo" (attributes.ml[14,189+4]..[14,189+7])
+ attribute "foo"
+ []
+ [
+ core_type (attributes.ml[14,189+12]..[14,189+13])
+ attribute "foo"
+ []
+ Ptyp_constr "t" (attributes.ml[14,189+12]..[14,189+13])
+ []
+ ]
+ None
+ ]
+ ptype_private = Public
+ ptype_manifest =
+ None
+ ]
+ structure_item (attributes.ml[17,226+0]..[17,226+8])
+ Pstr_attribute "foo"
+ []
+ structure_item (attributes.ml[20,237+0]..[29,344+7])
+ Pstr_module
+ "M" (attributes.ml[20,237+7]..[20,237+8])
+ attribute "foo"
+ []
+ module_expr (attributes.ml[20,237+11]..[28,334+3])
+ attribute "foo"
+ []
+ Pmod_structure
+ [
+ structure_item (attributes.ml[21,255+2]..[25,310+11])
+ Pstr_type Rec
+ [
+ type_declaration "t" (attributes.ml[21,255+7]..[21,255+8]) (attributes.ml[21,255+2]..[25,310+11])
+ attribute "foo"
+ []
+ attribute "foo"
+ []
+ ptype_params =
+ []
+ ptype_cstrs =
+ []
+ ptype_kind =
+ Ptype_record
+ [
+ (attributes.ml[22,268+4]..[22,268+25])
+ attribute "foo"
+ []
+ Immutable
+ "l" (attributes.ml[22,268+4]..[22,268+5]) core_type (attributes.ml[22,268+9]..[22,268+10])
+ attribute "foo"
+ []
+ Ptyp_constr "t" (attributes.ml[22,268+9]..[22,268+10])
+ []
+ ]
+ ptype_private = Public
+ ptype_manifest =
+ None
+ ]
+ structure_item (attributes.ml[27,323+2]..[27,323+10])
+ Pstr_attribute "foo"
+ []
+ ]
+ structure_item (attributes.ml[31,353+0]..[39,477+7])
+ Pstr_modtype "S" (attributes.ml[31,353+12]..[31,353+13])
+ attribute "foo"
+ []
+ module_type (attributes.ml[31,353+16]..[38,467+3])
+ attribute "foo"
+ []
+ Pmty_signature
+ [
+ signature_item (attributes.ml[33,374+2]..[34,442+11])
+ Psig_include
+ module_type (attributes.ml[33,374+10]..[33,374+61])
+ attribute "foo"
+ []
+ Pmty_with
+ module_type (attributes.ml[33,374+11]..[33,374+35])
+ attribute "foo"
+ []
+ Pmty_typeof
+ module_expr (attributes.ml[33,374+27]..[33,374+28])
+ attribute "foo"
+ []
+ Pmod_ident "M" (attributes.ml[33,374+27]..[33,374+28])
+ [
+ Pwith_typesubst "t" (attributes.ml[33,374+53]..[33,374+54])
+ type_declaration "t" (attributes.ml[33,374+53]..[33,374+54]) (attributes.ml[33,374+48]..[33,374+61])
+ ptype_params =
+ []
+ ptype_cstrs =
+ []
+ ptype_kind =
+ Ptype_abstract
+ ptype_private = Public
+ ptype_manifest =
+ Some
+ core_type (attributes.ml[33,374+58]..[33,374+61])
+ Ptyp_constr "M.t" (attributes.ml[33,374+58]..[33,374+61])
+ []
+ ]
+ attribute "foo"
+ []
+ signature_item (attributes.ml[36,455+2]..[36,455+10])
+ Psig_attribute "foo"
+ []
+ ]
+ structure_item (attributes.ml[41,486+0]..[41,486+8])
+ Pstr_attribute "foo"
+ []
+]
+
+(* TEST
+ flags = "-dparsetree"
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ *** check-ocamlc.byte-output
+*)
+
[@@@foo]
let (x[@foo]) : unit [@foo] = ()[@foo]
+++ /dev/null
-[
- structure_item (attributes.ml[1,0+0]..[1,0+8])
- Pstr_attribute "foo"
- []
- structure_item (attributes.ml[3,10+0]..[4,49+9])
- Pstr_value Nonrec
- [
- <def>
- attribute "foo"
- []
- pattern (attributes.ml[3,10+4]..[3,10+38]) ghost
- Ppat_constraint
- pattern (attributes.ml[3,10+4]..[3,10+13])
- attribute "foo"
- []
- Ppat_var "x" (attributes.ml[3,10+5]..[3,10+6])
- core_type (attributes.ml[3,10+16]..[3,10+20])
- attribute "foo"
- []
- Ptyp_constr "unit" (attributes.ml[3,10+16]..[3,10+20])
- []
- expression (attributes.ml[3,10+30]..[3,10+32])
- attribute "foo"
- []
- Pexp_construct "()" (attributes.ml[3,10+30]..[3,10+32])
- None
- ]
- structure_item (attributes.ml[6,60+0]..[8,97+7])
- Pstr_type Rec
- [
- type_declaration "t" (attributes.ml[6,60+5]..[6,60+6]) (attributes.ml[6,60+0]..[8,97+7])
- attribute "foo"
- []
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_variant
- [
- (attributes.ml[7,69+2]..[7,69+27])
- "Foo" (attributes.ml[7,69+4]..[7,69+7])
- attribute "foo"
- []
- [
- core_type (attributes.ml[7,69+12]..[7,69+13])
- attribute "foo"
- []
- Ptyp_constr "t" (attributes.ml[7,69+12]..[7,69+13])
- []
- ]
- None
- ]
- ptype_private = Public
- ptype_manifest =
- None
- ]
- structure_item (attributes.ml[10,106+0]..[10,106+8])
- Pstr_attribute "foo"
- []
- structure_item (attributes.ml[13,117+0]..[22,224+7])
- Pstr_module
- "M" (attributes.ml[13,117+7]..[13,117+8])
- attribute "foo"
- []
- module_expr (attributes.ml[13,117+11]..[21,214+3])
- attribute "foo"
- []
- Pmod_structure
- [
- structure_item (attributes.ml[14,135+2]..[18,190+11])
- Pstr_type Rec
- [
- type_declaration "t" (attributes.ml[14,135+7]..[14,135+8]) (attributes.ml[14,135+2]..[18,190+11])
- attribute "foo"
- []
- attribute "foo"
- []
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_record
- [
- (attributes.ml[15,148+4]..[15,148+25])
- attribute "foo"
- []
- Immutable
- "l" (attributes.ml[15,148+4]..[15,148+5]) core_type (attributes.ml[15,148+9]..[15,148+10])
- attribute "foo"
- []
- Ptyp_constr "t" (attributes.ml[15,148+9]..[15,148+10])
- []
- ]
- ptype_private = Public
- ptype_manifest =
- None
- ]
- structure_item (attributes.ml[20,203+2]..[20,203+10])
- Pstr_attribute "foo"
- []
- ]
- structure_item (attributes.ml[24,233+0]..[32,357+7])
- Pstr_modtype "S" (attributes.ml[24,233+12]..[24,233+13])
- attribute "foo"
- []
- module_type (attributes.ml[24,233+16]..[31,347+3])
- attribute "foo"
- []
- Pmty_signature
- [
- signature_item (attributes.ml[26,254+2]..[27,322+11])
- Psig_include
- module_type (attributes.ml[26,254+10]..[26,254+61])
- attribute "foo"
- []
- Pmty_with
- module_type (attributes.ml[26,254+11]..[26,254+35])
- attribute "foo"
- []
- Pmty_typeof
- module_expr (attributes.ml[26,254+27]..[26,254+28])
- attribute "foo"
- []
- Pmod_ident "M" (attributes.ml[26,254+27]..[26,254+28])
- [
- Pwith_typesubst "t" (attributes.ml[26,254+53]..[26,254+54])
- type_declaration "t" (attributes.ml[26,254+53]..[26,254+54]) (attributes.ml[26,254+48]..[26,254+61])
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_abstract
- ptype_private = Public
- ptype_manifest =
- Some
- core_type (attributes.ml[26,254+58]..[26,254+61])
- Ptyp_constr "M.t" (attributes.ml[26,254+58]..[26,254+61])
- []
- ]
- attribute "foo"
- []
- signature_item (attributes.ml[29,335+2]..[29,335+10])
- Psig_attribute "foo"
- []
- ]
- structure_item (attributes.ml[34,366+0]..[34,366+8])
- Pstr_attribute "foo"
- []
-]
-
+(* TEST
+ * expect
+ flags += " -dsource "
+*)
+
+(***********************************************************************)
+(* Test based on the example in the ocamldoc manual
+ Obviously some parts are different due to the simplified
+ rules used by the compiler *)
+
+module Manual : sig
+
+ (** Special comments can be placed between elements and are kept
+ by the OCamldoc tool, but are not associated to any element.
+ @-tags in these comments are ignored.*)
+
+ (*******************************************************************)
+ (** Comments like the one above, with more than two asterisks,
+ are ignored. *)
+
+ (** The comment for function f. *)
+ val f : int -> int -> int
+ (** The continuation of the comment for function f. *)
+
+ (** Comment for exception My_exception, even with a simple comment
+ between the special comment and the exception.*)
+ (* Hello, I'm a simple comment :-) *)
+ exception My_exception of (int -> int) * int
+
+ (** Comment for type weather *)
+ type weather =
+ | Rain of int (** The comment for constructor Rain *)
+ | Sun (** The comment for constructor Sun *)
+
+ (** Comment for type weather2 *)
+ type weather2 =
+ | Rain of int (** The comment for constructor Rain *)
+ | Sun (** The comment for constructor Sun *)
+ (** I can continue the comment for type weather2 here
+ because there is already a comment associated to the last constructor.*)
+
+ (** The comment for type my_record *)
+ type my_record = {
+ foo : int ; (** Comment for field foo *)
+ bar : string ; (** Comment for field bar *)
+ }
+ (** Continuation of comment for type my_record *)
+
+ (** Comment for foo *)
+ val foo : string
+ (** This comment is ambiguous and associated to both foo and bar. *)
+ val bar : string
+ (** This comment is associated to bar. *)
+
+ (** The comment for class my_class *)
+ class my_class : object
+ (** A comment to describe inheritance from cl *)
+ inherit cl
+
+ (** The comment for attribute tutu *)
+ val mutable tutu : string
+
+ (** The comment for attribute toto. *)
+ val toto : int
+
+ (** This comment is not attached to titi since
+ there is a blank line before titi, but is kept
+ as a comment in the class. *)
+
+ val titi : string
+
+ (** Comment for method toto *)
+ method toto : string
+
+ (** Comment for method m *)
+ method m : float -> int
+ end
+
+ (** The comment for the class type my_class_type *)
+ class type my_class_type = object
+ (** The comment for variable x. *)
+ val mutable x : int
+
+ (** The commend for method m. *)
+ method m : int -> int
+ end
+
+ (** The comment for module Foo *)
+ module Foo : sig
+ (** The comment for x *)
+ val x : int
+
+ (** A special comment that is kept but not associated to any element *)
+ end
+
+ (** The comment for module type my_module_type. *)
+ module type my_module_type = sig
+ (** The comment for value x. *)
+ val x : int
+
+ (** The comment for module M. *)
+ module M : sig
+ (** The comment for value y. *)
+ val y : int
+
+ (* ... *)
+ end
+
+ end
+
+end = struct
+
+ (** The comment for function f *)
+ let f x y = x + y
+
+ (** This comment is not attached to any element since there is another
+ special comment just before the next element. *)
+
+ (** Comment for exception My_exception, even with a simple comment
+ between the special comment and the exception.*)
+ (* A simple comment. *)
+ exception My_exception of (int -> int) * int
+
+ (** Comment for type weather *)
+ type weather =
+ | Rain of int (** The comment for constructor Rain *)
+ | Sun (** The comment for constructor Sun *)
+
+ (** The comment for type my_record *)
+ type my_record = {
+ foo : int ; (** Comment for field foo *)
+ bar : string ; (** Comment for field bar *)
+ }
+
+ (** The comment for class my_class *)
+ class my_class = object
+ (** A comment to describe inheritance from cl *)
+ inherit cl
+
+ (** The comment for the instance variable tutu *)
+ val mutable tutu = "tutu"
+
+ (** The comment for toto *)
+ val toto = 1
+ val titi = "titi"
+ (** Ambiguous comment on both titi and toto *)
+ method toto = tutu ^ "!"
+
+ (** The comment for method m *)
+ method m (f : float) = 1
+ end
+
+ (** The comment for class type my_class_type *)
+ class type my_class_type = object
+ (** The comment for the instance variable x. *)
+ val mutable x : int
+
+ (** The comment for method m. *)
+ method m : int -> int
+ end
+
+ (** The comment for module Foo *)
+ module Foo = struct
+ (** The comment for x *)
+ val x : int
+ (** Another comment for x *)
+ end
+
+ (** The comment for module type my_module_type. *)
+ module type my_module_type = sig
+ (* Comment for value x. *)
+ val x : int
+ (* ... *)
+ end
+
+end;;
+[%%expect {|
+
+module Manual :
+ sig
+ [@@@ocaml.text
+ " Special comments can be placed between elements and are kept\n by the OCamldoc tool, but are not associated to any element.\n @-tags in these comments are ignored."]
+ [@@@ocaml.text
+ " Comments like the one above, with more than two asterisks,\n are ignored. "]
+ val f : int -> int -> int[@@ocaml.doc " The comment for function f. "]
+ [@@ocaml.doc " The continuation of the comment for function f. "]
+ exception My_exception of (int -> int) * int
+ [@ocaml.doc
+ " Comment for exception My_exception, even with a simple comment\n between the special comment and the exception."]
+ type weather =
+ | Rain of int [@ocaml.doc " The comment for constructor Rain "]
+ | Sun [@ocaml.doc " The comment for constructor Sun "][@@ocaml.doc
+ " Comment for type weather "]
+ type weather2 =
+ | Rain of int [@ocaml.doc " The comment for constructor Rain "]
+ | Sun [@ocaml.doc " The comment for constructor Sun "][@@ocaml.doc
+ " Comment for type weather2 "]
+ [@@ocaml.doc
+ " I can continue the comment for type weather2 here\n because there is already a comment associated to the last constructor."]
+ type my_record =
+ {
+ foo: int [@ocaml.doc " Comment for field foo "];
+ bar: string [@ocaml.doc " Comment for field bar "]}[@@ocaml.doc
+ " The comment for type my_record "]
+ [@@ocaml.doc " Continuation of comment for type my_record "]
+ val foo : string[@@ocaml.doc " Comment for foo "][@@ocaml.doc
+ " This comment is ambiguous and associated to both foo and bar. "]
+ val bar : string[@@ocaml.doc
+ " This comment is ambiguous and associated to both foo and bar. "]
+ [@@ocaml.doc " This comment is associated to bar. "]
+ class my_class :
+ object
+ inherit cl[@@ocaml.doc " A comment to describe inheritance from cl "]
+ val mutable tutu : string[@@ocaml.doc
+ " The comment for attribute tutu "]
+ val toto : int[@@ocaml.doc " The comment for attribute toto. "]
+ [@@@ocaml.text
+ " This comment is not attached to titi since\n there is a blank line before titi, but is kept\n as a comment in the class. "]
+ val titi : string
+ method toto : string[@@ocaml.doc " Comment for method toto "]
+ method m : float -> int[@@ocaml.doc " Comment for method m "]
+ end[@@ocaml.doc " The comment for class my_class "]
+ class type my_class_type =
+ object
+ val mutable x : int[@@ocaml.doc " The comment for variable x. "]
+ method m : int -> int[@@ocaml.doc " The commend for method m. "]
+ end[@@ocaml.doc " The comment for the class type my_class_type "]
+ module Foo :
+ sig
+ val x : int[@@ocaml.doc " The comment for x "]
+ [@@@ocaml.text
+ " A special comment that is kept but not associated to any element "]
+ end[@@ocaml.doc " The comment for module Foo "]
+ module type my_module_type =
+ sig
+ val x : int[@@ocaml.doc " The comment for value x. "]
+ module M :
+ sig val y : int[@@ocaml.doc " The comment for value y. "] end
+ [@@ocaml.doc " The comment for module M. "]
+ end[@@ocaml.doc " The comment for module type my_module_type. "]
+ end =
+ struct
+ let f x y = x + y[@@ocaml.doc " The comment for function f "]
+ [@@@ocaml.text
+ " This comment is not attached to any element since there is another\n special comment just before the next element. "]
+ exception My_exception of (int -> int) * int
+ [@ocaml.doc
+ " Comment for exception My_exception, even with a simple comment\n between the special comment and the exception."]
+ type weather =
+ | Rain of int [@ocaml.doc " The comment for constructor Rain "]
+ | Sun [@ocaml.doc " The comment for constructor Sun "][@@ocaml.doc
+ " Comment for type weather "]
+ type my_record =
+ {
+ foo: int [@ocaml.doc " Comment for field foo "];
+ bar: string [@ocaml.doc " Comment for field bar "]}[@@ocaml.doc
+ " The comment for type my_record "]
+ class my_class =
+ object
+ inherit cl[@@ocaml.doc
+ " A comment to describe inheritance from cl "]
+ val mutable tutu = "tutu"[@@ocaml.doc
+ " The comment for the instance variable tutu "]
+ val toto = 1[@@ocaml.doc " The comment for toto "]
+ val titi = "titi"[@@ocaml.doc
+ " Ambiguous comment on both titi and toto "]
+ method toto = tutu ^ "!"[@@ocaml.doc
+ " Ambiguous comment on both titi and toto "]
+ method m (f : float) = 1[@@ocaml.doc " The comment for method m "]
+ end[@@ocaml.doc " The comment for class my_class "]
+ class type my_class_type =
+ object
+ val mutable x : int[@@ocaml.doc
+ " The comment for the instance variable x. "]
+ method m : int -> int[@@ocaml.doc " The comment for method m. "]
+ end[@@ocaml.doc " The comment for class type my_class_type "]
+ module Foo =
+ struct
+ external x : int[@@ocaml.doc " The comment for x "][@@ocaml.doc
+ " Another comment for x "]
+ end[@@ocaml.doc " The comment for module Foo "]
+ module type my_module_type = sig val x : int end[@@ocaml.doc
+ " The comment for module type my_module_type. "]
+ end ;;
+Line _, characters 12-14:
+ inherit cl
+ ^^
+Error: Unbound class cl
+|}]
+
+(***********************************************************************)
+(* Empty doc comments (GPR#548) *)
+
+module M = struct
+ type t = Label (**)
+ (** attached to t *)
+
+ (**)
+
+ (** Empty docstring comments should not generate attributes *)
+
+ type w (**)
+end;;
+[%%expect {|
+
+module M =
+ struct
+ type t =
+ | Label [@@ocaml.doc " attached to t "]
+ [@@@ocaml.text
+ " Empty docstring comments should not generate attributes "]
+ type w
+ end;;
+module M : sig type t = Label type w end
+|}]
+
+(***********************************************************************)
+(* Comments at the beginning and end of structures (MPR#7701) *)
+
+module M = struct
+ (** foo *)
+ type t
+
+ type s
+ (** bar *)
+end;;
+[%%expect {|
+
+module M = struct type t[@@ocaml.doc " foo "]
+ type s[@@ocaml.doc " bar "] end;;
+module M : sig type t type s end
+|}]
+
+module M = struct
+
+ (** foo *)
+ type t
+
+ type s
+ (** bar *)
+
+end;;
+[%%expect {|
+
+module M = struct type t[@@ocaml.doc " foo "]
+ type s[@@ocaml.doc " bar "] end;;
+module M : sig type t type s end
+|}]
+
+module M = struct
+ (** foo *)
+
+ type t
+
+ type s
+
+ (** bar *)
+end;;
+[%%expect {|
+
+module M =
+ struct [@@@ocaml.text " foo "]
+ type t
+ type s
+ [@@@ocaml.text " bar "] end;;
+module M : sig type t type s end
+|}]
+
+module M = struct
+
+ (** foo *)
+
+ type t
+
+ type s
+
+ (** bar *)
+
+end;;
+[%%expect {|
+
+module M =
+ struct [@@@ocaml.text " foo "]
+ type t
+ type s
+ [@@@ocaml.text " bar "] end;;
+module M : sig type t type s end
+|}]
+
+module M = struct
+
+ (** foo1: this comment is unattached *)
+ (** foo2 *)
+ type t
+
+ type s
+ (** bar1 *)
+ (** bar2: this comment is unattached *)
+
+end;;
+[%%expect {|
+
+module M =
+ struct type t[@@ocaml.doc " foo2 "]
+ type s[@@ocaml.doc " bar1 "] end;;
+module M : sig type t type s end
+|}]
+
+module M = struct
+ (** foo1 *)
+
+ (** foo2 *)
+
+ type t
+
+ type s
+
+ (** bar1 *)
+
+ (** bar2 *)
+end;;
+[%%expect {|
+
+module M =
+ struct
+ [@@@ocaml.text " foo1 "]
+ [@@@ocaml.text " foo2 "]
+ type t
+ type s
+ [@@@ocaml.text " bar1 "]
+ [@@@ocaml.text " bar2 "]
+ end;;
+module M : sig type t type s end
+|}]
+
+module M = struct
+
+ (** foo1 *)
+
+ (** foo2 *)
+
+ type t
+
+ type s
+
+ (** bar1 *)
+
+ (** bar2 *)
+
+end;;
+[%%expect {|
+
+module M =
+ struct
+ [@@@ocaml.text " foo1 "]
+ [@@@ocaml.text " foo2 "]
+ type t
+ type s
+ [@@@ocaml.text " bar1 "]
+ [@@@ocaml.text " bar2 "]
+ end;;
+module M : sig type t type s end
+|}]
+
+module M = struct (** foo *) type t (** bar *) end;;
+[%%expect {|
+
+module M = struct type t[@@ocaml.doc " foo "][@@ocaml.doc " bar "] end;;
+module M : sig type t end
+|}]
+
+module M = struct (** foo *)
+
+type t
+
+(** bar *) end;;
+[%%expect {|
+
+module M = struct [@@@ocaml.text " foo "]
+ type t
+ [@@@ocaml.text " bar "] end;;
+module M : sig type t end
+|}]
+
+module M = struct (** foo *) end;;
+[%%expect {|
+
+module M = struct [@@@ocaml.text " foo "] end;;
+module M : sig end
+|}]
+
+module M = struct (** foo *)
+
+end;;
+[%%expect {|
+
+module M = struct [@@@ocaml.text " foo "] end;;
+module M : sig end
+|}]
+
+module M = struct
+
+(** foo *) end;;
+[%%expect {|
+
+module M = struct [@@@ocaml.text " foo "] end;;
+module M : sig end
+|}]
+
+module M = struct
+(** foo *)
+end;;
+[%%expect {|
+
+module M = struct [@@@ocaml.text " foo "] end;;
+module M : sig end
+|}]
+
+module M = struct
+
+(** foo *)
+end;;
+[%%expect {|
+
+module M = struct [@@@ocaml.text " foo "] end;;
+module M : sig end
+|}]
+
+module M = struct
+(** foo *)
+
+end;;
+[%%expect {|
+
+module M = struct [@@@ocaml.text " foo "] end;;
+module M : sig end
+|}]
+
+module M = struct
+
+(** foo *)
+
+end;;
+[%%expect {|
+
+module M = struct [@@@ocaml.text " foo "] end;;
+module M : sig end
+|}]
+
+module M = struct
+
+(** foo *)
+
+(** bar *)
+
+end;;
+[%%expect {|
+
+module M = struct [@@@ocaml.text " foo "]
+ [@@@ocaml.text " bar "] end;;
+module M : sig end
+|}]
+
+module M = struct
+(** foo *)
+
+(** bar *)
+end;;
+[%%expect {|
+
+module M = struct [@@@ocaml.text " foo "]
+ [@@@ocaml.text " bar "] end;;
+module M : sig end
+|}]
+
+
+(*****************************************************************************)
+(* Comments on parameters, variant constructors and object methods (GPR#477) *)
+
type 'a with_default
= ?size:int (** default [42] *)
-> ?resizable:bool (** default [true] *)
- -> 'a
+ -> 'a;;
+[%%expect {|
+
+type 'a with_default =
+ ?size:((int)[@ocaml.doc " default [42] "]) ->
+ ?resizable:((bool)[@ocaml.doc " default [true] "]) -> 'a;;
+type 'a with_default = ?size:int -> ?resizable:bool -> 'a
+|}]
type obj = <
meth1 : int -> int;
(** method 1 *)
meth2: unit -> float (** method 2 *);
->
+>;;
+[%%expect {|
+
+type obj =
+ <
+ meth1: int -> int [@ocaml.doc " method 1 "] ;meth2: unit -> float
+ [@ocaml.doc " method 2 "]
+ > ;;
+type obj = < meth1 : int -> int; meth2 : unit -> float >
+|}]
type var = [
| `Foo (** foo *)
| `Bar of int * string (** bar *)
-]
+];;
+[%%expect {|
+
+type var =
+ [ `Foo [@ocaml.doc " foo "] | `Bar of (int * string) [@ocaml.doc " bar "]];;
+type var = [ `Bar of int * string | `Foo ]
+|}]
+++ /dev/null
-[
- structure_item (docstrings.ml[1,0+0]..[4,105+7])
- Pstr_type Rec
- [
- type_declaration "with_default" (docstrings.ml[1,0+8]..[1,0+20]) (docstrings.ml[1,0+0]..[4,105+7])
- ptype_params =
- [
- core_type (docstrings.ml[1,0+5]..[1,0+7])
- Ptyp_var a
- ]
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_abstract
- ptype_private = Public
- ptype_manifest =
- Some
- core_type (docstrings.ml[2,21+5]..[4,105+7])
- Ptyp_arrow
- Optional "size"
- core_type (docstrings.ml[2,21+11]..[2,21+14])
- attribute "ocaml.doc"
- [
- structure_item (docstrings.ml[2,21+21]..[2,21+40])
- Pstr_eval
- expression (docstrings.ml[2,21+21]..[2,21+40])
- Pexp_constant PConst_string(" default [42] ",None)
- ]
- Ptyp_constr "int" (docstrings.ml[2,21+11]..[2,21+14])
- []
- core_type (docstrings.ml[3,62+5]..[4,105+7])
- Ptyp_arrow
- Optional "resizable"
- core_type (docstrings.ml[3,62+16]..[3,62+20])
- attribute "ocaml.doc"
- [
- structure_item (docstrings.ml[3,62+21]..[3,62+42])
- Pstr_eval
- expression (docstrings.ml[3,62+21]..[3,62+42])
- Pexp_constant PConst_string(" default [true] ",None)
- ]
- Ptyp_constr "bool" (docstrings.ml[3,62+16]..[3,62+20])
- []
- core_type (docstrings.ml[4,105+5]..[4,105+7])
- Ptyp_var a
- ]
- structure_item (docstrings.ml[6,114+0]..[11,208+1])
- Pstr_type Rec
- [
- type_declaration "obj" (docstrings.ml[6,114+5]..[6,114+8]) (docstrings.ml[6,114+0]..[11,208+1])
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_abstract
- ptype_private = Public
- ptype_manifest =
- Some
- core_type (docstrings.ml[6,114+11]..[11,208+1])
- Ptyp_object Closed
- method meth1
- attribute "ocaml.doc"
- [
- structure_item (docstrings.ml[8,149+2]..[8,149+17])
- Pstr_eval
- expression (docstrings.ml[8,149+2]..[8,149+17])
- Pexp_constant PConst_string(" method 1 ",None)
- ]
- core_type (docstrings.ml[7,127+10]..[7,127+20])
- Ptyp_arrow
- Nolabel
- core_type (docstrings.ml[7,127+10]..[7,127+13])
- Ptyp_constr "int" (docstrings.ml[7,127+10]..[7,127+13])
- []
- core_type (docstrings.ml[7,127+17]..[7,127+20])
- Ptyp_constr "int" (docstrings.ml[7,127+17]..[7,127+20])
- []
- method meth2
- attribute "ocaml.doc"
- [
- structure_item (docstrings.ml[10,168+23]..[10,168+38])
- Pstr_eval
- expression (docstrings.ml[10,168+23]..[10,168+38])
- Pexp_constant PConst_string(" method 2 ",None)
- ]
- core_type (docstrings.ml[10,168+9]..[10,168+22])
- Ptyp_arrow
- Nolabel
- core_type (docstrings.ml[10,168+9]..[10,168+13])
- Ptyp_constr "unit" (docstrings.ml[10,168+9]..[10,168+13])
- []
- core_type (docstrings.ml[10,168+17]..[10,168+22])
- Ptyp_constr "float" (docstrings.ml[10,168+17]..[10,168+22])
- []
- ]
- structure_item (docstrings.ml[13,211+0]..[16,280+1])
- Pstr_type Rec
- [
- type_declaration "var" (docstrings.ml[13,211+5]..[13,211+8]) (docstrings.ml[13,211+0]..[16,280+1])
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_abstract
- ptype_private = Public
- ptype_manifest =
- Some
- core_type (docstrings.ml[13,211+11]..[16,280+1])
- Ptyp_variant closed=Closed
- [
- Rtag "Foo" true
- attribute "ocaml.doc"
- [
- structure_item (docstrings.ml[14,224+9]..[14,224+19])
- Pstr_eval
- expression (docstrings.ml[14,224+9]..[14,224+19])
- Pexp_constant PConst_string(" foo ",None)
- ]
- []
- Rtag "Bar" false
- attribute "ocaml.doc"
- [
- structure_item (docstrings.ml[15,244+25]..[15,244+35])
- Pstr_eval
- expression (docstrings.ml[15,244+25]..[15,244+35])
- Pexp_constant PConst_string(" bar ",None)
- ]
- [
- core_type (docstrings.ml[15,244+12]..[15,244+24])
- Ptyp_tuple
- [
- core_type (docstrings.ml[15,244+12]..[15,244+15])
- Ptyp_constr "int" (docstrings.ml[15,244+12]..[15,244+15])
- []
- core_type (docstrings.ml[15,244+18]..[15,244+24])
- Ptyp_constr "string" (docstrings.ml[15,244+18]..[15,244+24])
- []
- ]
- ]
- ]
- None
- ]
-]
-
--- /dev/null
+[
+ structure_item (extended_indexoperators.ml[8,120+0]..[8,120+29])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extended_indexoperators.ml[8,120+4]..[8,120+10])
+ Ppat_var ".?[]" (extended_indexoperators.ml[8,120+4]..[8,120+10])
+ expression (extended_indexoperators.ml[8,120+13]..[8,120+29])
+ Pexp_ident "Hashtbl.find_opt" (extended_indexoperators.ml[8,120+13]..[8,120+29])
+ ]
+ structure_item (extended_indexoperators.ml[9,150+0]..[9,150+25])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extended_indexoperators.ml[9,150+4]..[9,150+10])
+ Ppat_var ".@[]" (extended_indexoperators.ml[9,150+4]..[9,150+10])
+ expression (extended_indexoperators.ml[9,150+13]..[9,150+25])
+ Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[9,150+13]..[9,150+25])
+ ]
+ structure_item (extended_indexoperators.ml[10,176+0]..[10,176+28])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extended_indexoperators.ml[10,176+4]..[10,176+14])
+ Ppat_var ".@[]<-" (extended_indexoperators.ml[10,176+4]..[10,176+14])
+ expression (extended_indexoperators.ml[10,176+17]..[10,176+28])
+ Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[10,176+17]..[10,176+28])
+ ]
+ structure_item (extended_indexoperators.ml[11,205+0]..[11,205+25])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extended_indexoperators.ml[11,205+4]..[11,205+10])
+ Ppat_var ".@{}" (extended_indexoperators.ml[11,205+4]..[11,205+10])
+ expression (extended_indexoperators.ml[11,205+13]..[11,205+25])
+ Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[11,205+13]..[11,205+25])
+ ]
+ structure_item (extended_indexoperators.ml[12,231+0]..[12,231+28])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extended_indexoperators.ml[12,231+4]..[12,231+14])
+ Ppat_var ".@{}<-" (extended_indexoperators.ml[12,231+4]..[12,231+14])
+ expression (extended_indexoperators.ml[12,231+17]..[12,231+28])
+ Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[12,231+17]..[12,231+28])
+ ]
+ structure_item (extended_indexoperators.ml[13,260+0]..[13,260+25])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extended_indexoperators.ml[13,260+4]..[13,260+10])
+ Ppat_var ".@()" (extended_indexoperators.ml[13,260+4]..[13,260+10])
+ expression (extended_indexoperators.ml[13,260+13]..[13,260+25])
+ Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[13,260+13]..[13,260+25])
+ ]
+ structure_item (extended_indexoperators.ml[14,286+0]..[14,286+28])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extended_indexoperators.ml[14,286+4]..[14,286+14])
+ Ppat_var ".@()<-" (extended_indexoperators.ml[14,286+4]..[14,286+14])
+ expression (extended_indexoperators.ml[14,286+17]..[14,286+28])
+ Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[14,286+17]..[14,286+28])
+ ]
+ structure_item (extended_indexoperators.ml[16,316+0]..[16,316+25])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extended_indexoperators.ml[16,316+4]..[16,316+5])
+ Ppat_var "h" (extended_indexoperators.ml[16,316+4]..[16,316+5])
+ expression (extended_indexoperators.ml[16,316+8]..[16,316+25])
+ Pexp_apply
+ expression (extended_indexoperators.ml[16,316+8]..[16,316+22])
+ Pexp_ident "Hashtbl.create" (extended_indexoperators.ml[16,316+8]..[16,316+22])
+ [
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[16,316+23]..[16,316+25])
+ Pexp_constant PConst_int (17,None)
+ ]
+ ]
+ structure_item (extended_indexoperators.ml[19,346+2]..[22,413+28])
+ Pstr_eval
+ expression (extended_indexoperators.ml[19,346+2]..[22,413+28])
+ Pexp_sequence
+ expression (extended_indexoperators.ml[19,346+2]..[19,346+17])
+ Pexp_apply
+ expression (extended_indexoperators.ml[19,346+2]..[19,346+17])
+ Pexp_ident ".@()<-" (extended_indexoperators.ml[19,346+2]..[19,346+17]) ghost
+ [
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[19,346+2]..[19,346+3])
+ Pexp_ident "h" (extended_indexoperators.ml[19,346+2]..[19,346+3])
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[19,346+6]..[19,346+11])
+ Pexp_constant PConst_string("One",None)
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[19,346+16]..[19,346+17])
+ Pexp_constant PConst_int (1,None)
+ ]
+ expression (extended_indexoperators.ml[20,364+2]..[22,413+28])
+ Pexp_sequence
+ expression (extended_indexoperators.ml[20,364+2]..[20,364+25])
+ Pexp_assert
+ expression (extended_indexoperators.ml[20,364+9]..[20,364+25])
+ Pexp_apply
+ expression (extended_indexoperators.ml[20,364+21]..[20,364+22])
+ Pexp_ident "=" (extended_indexoperators.ml[20,364+21]..[20,364+22])
+ [
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[20,364+10]..[20,364+20])
+ Pexp_apply
+ expression (extended_indexoperators.ml[20,364+10]..[20,364+20])
+ Pexp_ident ".@{}" (extended_indexoperators.ml[20,364+10]..[20,364+20]) ghost
+ [
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[20,364+10]..[20,364+11])
+ Pexp_ident "h" (extended_indexoperators.ml[20,364+10]..[20,364+11])
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[20,364+14]..[20,364+19])
+ Pexp_constant PConst_string("One",None)
+ ]
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[20,364+23]..[20,364+24])
+ Pexp_constant PConst_int (1,None)
+ ]
+ expression (extended_indexoperators.ml[21,390+2]..[22,413+28])
+ Pexp_sequence
+ expression (extended_indexoperators.ml[21,390+2]..[21,390+22])
+ Pexp_apply
+ expression (extended_indexoperators.ml[21,390+2]..[21,390+11])
+ Pexp_ident "print_int" (extended_indexoperators.ml[21,390+2]..[21,390+11])
+ [
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[21,390+12]..[21,390+22])
+ Pexp_apply
+ expression (extended_indexoperators.ml[21,390+12]..[21,390+22])
+ Pexp_ident ".@{}" (extended_indexoperators.ml[21,390+12]..[21,390+22]) ghost
+ [
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[21,390+12]..[21,390+13])
+ Pexp_ident "h" (extended_indexoperators.ml[21,390+12]..[21,390+13])
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[21,390+16]..[21,390+21])
+ Pexp_constant PConst_string("One",None)
+ ]
+ ]
+ expression (extended_indexoperators.ml[22,413+2]..[22,413+28])
+ Pexp_assert
+ expression (extended_indexoperators.ml[22,413+9]..[22,413+28])
+ Pexp_apply
+ expression (extended_indexoperators.ml[22,413+21]..[22,413+22])
+ Pexp_ident "=" (extended_indexoperators.ml[22,413+21]..[22,413+22])
+ [
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[22,413+10]..[22,413+20])
+ Pexp_apply
+ expression (extended_indexoperators.ml[22,413+10]..[22,413+20])
+ Pexp_ident ".?[]" (extended_indexoperators.ml[22,413+10]..[22,413+20]) ghost
+ [
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[22,413+10]..[22,413+11])
+ Pexp_ident "h" (extended_indexoperators.ml[22,413+10]..[22,413+11])
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[22,413+14]..[22,413+19])
+ Pexp_constant PConst_string("Two",None)
+ ]
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[22,413+23]..[22,413+27])
+ Pexp_construct "None" (extended_indexoperators.ml[22,413+23]..[22,413+27])
+ None
+ ]
+ structure_item (extended_indexoperators.ml[26,464+0]..[26,464+23])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extended_indexoperators.ml[26,464+4]..[26,464+10])
+ Ppat_var "#?" (extended_indexoperators.ml[26,464+4]..[26,464+10])
+ expression (extended_indexoperators.ml[26,464+11]..[26,464+23]) ghost
+ Pexp_fun
+ Nolabel
+ None
+ pattern (extended_indexoperators.ml[26,464+11]..[26,464+12])
+ Ppat_var "x" (extended_indexoperators.ml[26,464+11]..[26,464+12])
+ expression (extended_indexoperators.ml[26,464+13]..[26,464+23]) ghost
+ Pexp_fun
+ Nolabel
+ None
+ pattern (extended_indexoperators.ml[26,464+13]..[26,464+14])
+ Ppat_var "y" (extended_indexoperators.ml[26,464+13]..[26,464+14])
+ expression (extended_indexoperators.ml[26,464+17]..[26,464+23])
+ Pexp_tuple
+ [
+ expression (extended_indexoperators.ml[26,464+18]..[26,464+19])
+ Pexp_ident "x" (extended_indexoperators.ml[26,464+18]..[26,464+19])
+ expression (extended_indexoperators.ml[26,464+21]..[26,464+22])
+ Pexp_ident "y" (extended_indexoperators.ml[26,464+21]..[26,464+22])
+ ]
+ ]
+ structure_item (extended_indexoperators.ml[27,490+0]..[27,490+24])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extended_indexoperators.ml[27,490+4]..[27,490+12])
+ Ppat_var ".%()" (extended_indexoperators.ml[27,490+4]..[27,490+12])
+ expression (extended_indexoperators.ml[27,490+13]..[27,490+24]) ghost
+ Pexp_fun
+ Nolabel
+ None
+ pattern (extended_indexoperators.ml[27,490+13]..[27,490+14])
+ Ppat_var "x" (extended_indexoperators.ml[27,490+13]..[27,490+14])
+ expression (extended_indexoperators.ml[27,490+15]..[27,490+24]) ghost
+ Pexp_fun
+ Nolabel
+ None
+ pattern (extended_indexoperators.ml[27,490+15]..[27,490+16])
+ Ppat_var "y" (extended_indexoperators.ml[27,490+15]..[27,490+16])
+ expression (extended_indexoperators.ml[27,490+19]..[27,490+24])
+ Pexp_apply
+ expression (extended_indexoperators.ml[27,490+19]..[27,490+24]) ghost
+ Pexp_ident "Array.get" (extended_indexoperators.ml[27,490+19]..[27,490+24]) ghost
+ [
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[27,490+19]..[27,490+20])
+ Pexp_ident "x" (extended_indexoperators.ml[27,490+19]..[27,490+20])
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[27,490+22]..[27,490+23])
+ Pexp_ident "y" (extended_indexoperators.ml[27,490+22]..[27,490+23])
+ ]
+ ]
+ structure_item (extended_indexoperators.ml[28,517+0]..[28,517+15])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extended_indexoperators.ml[28,517+4]..[28,517+5])
+ Ppat_var "x" (extended_indexoperators.ml[28,517+4]..[28,517+5])
+ expression (extended_indexoperators.ml[28,517+8]..[28,517+15])
+ Pexp_array
+ [
+ expression (extended_indexoperators.ml[28,517+11]..[28,517+12])
+ Pexp_constant PConst_int (0,None)
+ ]
+ ]
+ structure_item (extended_indexoperators.ml[29,535+0]..[29,535+18])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extended_indexoperators.ml[29,535+4]..[29,535+5])
+ Ppat_any
+ expression (extended_indexoperators.ml[29,535+8]..[29,535+18])
+ Pexp_apply
+ expression (extended_indexoperators.ml[29,535+10]..[29,535+12])
+ Pexp_ident "#?" (extended_indexoperators.ml[29,535+10]..[29,535+12])
+ [
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[29,535+8]..[29,535+9])
+ Pexp_constant PConst_int (1,None)
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[29,535+13]..[29,535+18])
+ Pexp_apply
+ expression (extended_indexoperators.ml[29,535+13]..[29,535+18]) ghost
+ Pexp_ident "Array.get" (extended_indexoperators.ml[29,535+13]..[29,535+18]) ghost
+ [
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[29,535+13]..[29,535+14])
+ Pexp_ident "x" (extended_indexoperators.ml[29,535+13]..[29,535+14])
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[29,535+16]..[29,535+17])
+ Pexp_constant PConst_int (0,None)
+ ]
+ ]
+ ]
+ structure_item (extended_indexoperators.ml[30,556+0]..[30,556+19])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extended_indexoperators.ml[30,556+4]..[30,556+5])
+ Ppat_any
+ expression (extended_indexoperators.ml[30,556+8]..[30,556+19])
+ Pexp_apply
+ expression (extended_indexoperators.ml[30,556+10]..[30,556+12])
+ Pexp_ident "#?" (extended_indexoperators.ml[30,556+10]..[30,556+12])
+ [
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[30,556+8]..[30,556+9])
+ Pexp_constant PConst_int (1,None)
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[30,556+13]..[30,556+19])
+ Pexp_apply
+ expression (extended_indexoperators.ml[30,556+13]..[30,556+19])
+ Pexp_ident ".%()" (extended_indexoperators.ml[30,556+13]..[30,556+19]) ghost
+ [
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[30,556+13]..[30,556+14])
+ Pexp_ident "x" (extended_indexoperators.ml[30,556+13]..[30,556+14])
+ <arg>
+ Nolabel
+ expression (extended_indexoperators.ml[30,556+17]..[30,556+18])
+ Pexp_constant PConst_int (0,None)
+ ]
+ ]
+ ]
+]
+
+(* TEST
+ flags = "-dparsetree"
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ *** check-ocamlc.byte-output
+*)
+
let (.?[]) = Hashtbl.find_opt
let (.@[]) = Hashtbl.find
let ( .@[]<- ) = Hashtbl.add
+++ /dev/null
-[
- structure_item (extended_indexoperators.ml[1,0+0]..[1,0+29])
- Pstr_value Nonrec
- [
- <def>
- pattern (extended_indexoperators.ml[1,0+4]..[1,0+10])
- Ppat_var ".?[]" (extended_indexoperators.ml[1,0+4]..[1,0+10])
- expression (extended_indexoperators.ml[1,0+13]..[1,0+29])
- Pexp_ident "Hashtbl.find_opt" (extended_indexoperators.ml[1,0+13]..[1,0+29])
- ]
- structure_item (extended_indexoperators.ml[2,30+0]..[2,30+25])
- Pstr_value Nonrec
- [
- <def>
- pattern (extended_indexoperators.ml[2,30+4]..[2,30+10])
- Ppat_var ".@[]" (extended_indexoperators.ml[2,30+4]..[2,30+10])
- expression (extended_indexoperators.ml[2,30+13]..[2,30+25])
- Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[2,30+13]..[2,30+25])
- ]
- structure_item (extended_indexoperators.ml[3,56+0]..[3,56+28])
- Pstr_value Nonrec
- [
- <def>
- pattern (extended_indexoperators.ml[3,56+4]..[3,56+14])
- Ppat_var ".@[]<-" (extended_indexoperators.ml[3,56+4]..[3,56+14])
- expression (extended_indexoperators.ml[3,56+17]..[3,56+28])
- Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[3,56+17]..[3,56+28])
- ]
- structure_item (extended_indexoperators.ml[4,85+0]..[4,85+25])
- Pstr_value Nonrec
- [
- <def>
- pattern (extended_indexoperators.ml[4,85+4]..[4,85+10])
- Ppat_var ".@{}" (extended_indexoperators.ml[4,85+4]..[4,85+10])
- expression (extended_indexoperators.ml[4,85+13]..[4,85+25])
- Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[4,85+13]..[4,85+25])
- ]
- structure_item (extended_indexoperators.ml[5,111+0]..[5,111+28])
- Pstr_value Nonrec
- [
- <def>
- pattern (extended_indexoperators.ml[5,111+4]..[5,111+14])
- Ppat_var ".@{}<-" (extended_indexoperators.ml[5,111+4]..[5,111+14])
- expression (extended_indexoperators.ml[5,111+17]..[5,111+28])
- Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[5,111+17]..[5,111+28])
- ]
- structure_item (extended_indexoperators.ml[6,140+0]..[6,140+25])
- Pstr_value Nonrec
- [
- <def>
- pattern (extended_indexoperators.ml[6,140+4]..[6,140+10])
- Ppat_var ".@()" (extended_indexoperators.ml[6,140+4]..[6,140+10])
- expression (extended_indexoperators.ml[6,140+13]..[6,140+25])
- Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[6,140+13]..[6,140+25])
- ]
- structure_item (extended_indexoperators.ml[7,166+0]..[7,166+28])
- Pstr_value Nonrec
- [
- <def>
- pattern (extended_indexoperators.ml[7,166+4]..[7,166+14])
- Ppat_var ".@()<-" (extended_indexoperators.ml[7,166+4]..[7,166+14])
- expression (extended_indexoperators.ml[7,166+17]..[7,166+28])
- Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[7,166+17]..[7,166+28])
- ]
- structure_item (extended_indexoperators.ml[9,196+0]..[9,196+25])
- Pstr_value Nonrec
- [
- <def>
- pattern (extended_indexoperators.ml[9,196+4]..[9,196+5])
- Ppat_var "h" (extended_indexoperators.ml[9,196+4]..[9,196+5])
- expression (extended_indexoperators.ml[9,196+8]..[9,196+25])
- Pexp_apply
- expression (extended_indexoperators.ml[9,196+8]..[9,196+22])
- Pexp_ident "Hashtbl.create" (extended_indexoperators.ml[9,196+8]..[9,196+22])
- [
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[9,196+23]..[9,196+25])
- Pexp_constant PConst_int (17,None)
- ]
- ]
- structure_item (extended_indexoperators.ml[12,226+2]..[15,293+28])
- Pstr_eval
- expression (extended_indexoperators.ml[12,226+2]..[15,293+28])
- Pexp_sequence
- expression (extended_indexoperators.ml[12,226+2]..[12,226+17])
- Pexp_apply
- expression (extended_indexoperators.ml[12,226+2]..[12,226+17])
- Pexp_ident ".@()<-" (extended_indexoperators.ml[12,226+2]..[12,226+17]) ghost
- [
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[12,226+2]..[12,226+3])
- Pexp_ident "h" (extended_indexoperators.ml[12,226+2]..[12,226+3])
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[12,226+6]..[12,226+11])
- Pexp_constant PConst_string("One",None)
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[12,226+16]..[12,226+17])
- Pexp_constant PConst_int (1,None)
- ]
- expression (extended_indexoperators.ml[13,244+2]..[15,293+28])
- Pexp_sequence
- expression (extended_indexoperators.ml[13,244+2]..[13,244+25])
- Pexp_assert
- expression (extended_indexoperators.ml[13,244+9]..[13,244+25])
- Pexp_apply
- expression (extended_indexoperators.ml[13,244+21]..[13,244+22])
- Pexp_ident "=" (extended_indexoperators.ml[13,244+21]..[13,244+22])
- [
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[13,244+10]..[13,244+20])
- Pexp_apply
- expression (extended_indexoperators.ml[13,244+10]..[13,244+20])
- Pexp_ident ".@{}" (extended_indexoperators.ml[13,244+10]..[13,244+20]) ghost
- [
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[13,244+10]..[13,244+11])
- Pexp_ident "h" (extended_indexoperators.ml[13,244+10]..[13,244+11])
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[13,244+14]..[13,244+19])
- Pexp_constant PConst_string("One",None)
- ]
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[13,244+23]..[13,244+24])
- Pexp_constant PConst_int (1,None)
- ]
- expression (extended_indexoperators.ml[14,270+2]..[15,293+28])
- Pexp_sequence
- expression (extended_indexoperators.ml[14,270+2]..[14,270+22])
- Pexp_apply
- expression (extended_indexoperators.ml[14,270+2]..[14,270+11])
- Pexp_ident "print_int" (extended_indexoperators.ml[14,270+2]..[14,270+11])
- [
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[14,270+12]..[14,270+22])
- Pexp_apply
- expression (extended_indexoperators.ml[14,270+12]..[14,270+22])
- Pexp_ident ".@{}" (extended_indexoperators.ml[14,270+12]..[14,270+22]) ghost
- [
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[14,270+12]..[14,270+13])
- Pexp_ident "h" (extended_indexoperators.ml[14,270+12]..[14,270+13])
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[14,270+16]..[14,270+21])
- Pexp_constant PConst_string("One",None)
- ]
- ]
- expression (extended_indexoperators.ml[15,293+2]..[15,293+28])
- Pexp_assert
- expression (extended_indexoperators.ml[15,293+9]..[15,293+28])
- Pexp_apply
- expression (extended_indexoperators.ml[15,293+21]..[15,293+22])
- Pexp_ident "=" (extended_indexoperators.ml[15,293+21]..[15,293+22])
- [
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[15,293+10]..[15,293+20])
- Pexp_apply
- expression (extended_indexoperators.ml[15,293+10]..[15,293+20])
- Pexp_ident ".?[]" (extended_indexoperators.ml[15,293+10]..[15,293+20]) ghost
- [
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[15,293+10]..[15,293+11])
- Pexp_ident "h" (extended_indexoperators.ml[15,293+10]..[15,293+11])
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[15,293+14]..[15,293+19])
- Pexp_constant PConst_string("Two",None)
- ]
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[15,293+23]..[15,293+27])
- Pexp_construct "None" (extended_indexoperators.ml[15,293+23]..[15,293+27])
- None
- ]
- structure_item (extended_indexoperators.ml[19,344+0]..[19,344+23])
- Pstr_value Nonrec
- [
- <def>
- pattern (extended_indexoperators.ml[19,344+4]..[19,344+10])
- Ppat_var "#?" (extended_indexoperators.ml[19,344+4]..[19,344+10])
- expression (extended_indexoperators.ml[19,344+11]..[19,344+23]) ghost
- Pexp_fun
- Nolabel
- None
- pattern (extended_indexoperators.ml[19,344+11]..[19,344+12])
- Ppat_var "x" (extended_indexoperators.ml[19,344+11]..[19,344+12])
- expression (extended_indexoperators.ml[19,344+13]..[19,344+23]) ghost
- Pexp_fun
- Nolabel
- None
- pattern (extended_indexoperators.ml[19,344+13]..[19,344+14])
- Ppat_var "y" (extended_indexoperators.ml[19,344+13]..[19,344+14])
- expression (extended_indexoperators.ml[19,344+17]..[19,344+23])
- Pexp_tuple
- [
- expression (extended_indexoperators.ml[19,344+18]..[19,344+19])
- Pexp_ident "x" (extended_indexoperators.ml[19,344+18]..[19,344+19])
- expression (extended_indexoperators.ml[19,344+21]..[19,344+22])
- Pexp_ident "y" (extended_indexoperators.ml[19,344+21]..[19,344+22])
- ]
- ]
- structure_item (extended_indexoperators.ml[20,370+0]..[20,370+24])
- Pstr_value Nonrec
- [
- <def>
- pattern (extended_indexoperators.ml[20,370+4]..[20,370+12])
- Ppat_var ".%()" (extended_indexoperators.ml[20,370+4]..[20,370+12])
- expression (extended_indexoperators.ml[20,370+13]..[20,370+24]) ghost
- Pexp_fun
- Nolabel
- None
- pattern (extended_indexoperators.ml[20,370+13]..[20,370+14])
- Ppat_var "x" (extended_indexoperators.ml[20,370+13]..[20,370+14])
- expression (extended_indexoperators.ml[20,370+15]..[20,370+24]) ghost
- Pexp_fun
- Nolabel
- None
- pattern (extended_indexoperators.ml[20,370+15]..[20,370+16])
- Ppat_var "y" (extended_indexoperators.ml[20,370+15]..[20,370+16])
- expression (extended_indexoperators.ml[20,370+19]..[20,370+24])
- Pexp_apply
- expression (extended_indexoperators.ml[20,370+19]..[20,370+24]) ghost
- Pexp_ident "Array.get" (extended_indexoperators.ml[20,370+19]..[20,370+24]) ghost
- [
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[20,370+19]..[20,370+20])
- Pexp_ident "x" (extended_indexoperators.ml[20,370+19]..[20,370+20])
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[20,370+22]..[20,370+23])
- Pexp_ident "y" (extended_indexoperators.ml[20,370+22]..[20,370+23])
- ]
- ]
- structure_item (extended_indexoperators.ml[21,397+0]..[21,397+15])
- Pstr_value Nonrec
- [
- <def>
- pattern (extended_indexoperators.ml[21,397+4]..[21,397+5])
- Ppat_var "x" (extended_indexoperators.ml[21,397+4]..[21,397+5])
- expression (extended_indexoperators.ml[21,397+8]..[21,397+15])
- Pexp_array
- [
- expression (extended_indexoperators.ml[21,397+11]..[21,397+12])
- Pexp_constant PConst_int (0,None)
- ]
- ]
- structure_item (extended_indexoperators.ml[22,415+0]..[22,415+18])
- Pstr_value Nonrec
- [
- <def>
- pattern (extended_indexoperators.ml[22,415+4]..[22,415+5])
- Ppat_any
- expression (extended_indexoperators.ml[22,415+8]..[22,415+18])
- Pexp_apply
- expression (extended_indexoperators.ml[22,415+10]..[22,415+12])
- Pexp_ident "#?" (extended_indexoperators.ml[22,415+10]..[22,415+12])
- [
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[22,415+8]..[22,415+9])
- Pexp_constant PConst_int (1,None)
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[22,415+13]..[22,415+18])
- Pexp_apply
- expression (extended_indexoperators.ml[22,415+13]..[22,415+18]) ghost
- Pexp_ident "Array.get" (extended_indexoperators.ml[22,415+13]..[22,415+18]) ghost
- [
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[22,415+13]..[22,415+14])
- Pexp_ident "x" (extended_indexoperators.ml[22,415+13]..[22,415+14])
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[22,415+16]..[22,415+17])
- Pexp_constant PConst_int (0,None)
- ]
- ]
- ]
- structure_item (extended_indexoperators.ml[23,436+0]..[23,436+19])
- Pstr_value Nonrec
- [
- <def>
- pattern (extended_indexoperators.ml[23,436+4]..[23,436+5])
- Ppat_any
- expression (extended_indexoperators.ml[23,436+8]..[23,436+19])
- Pexp_apply
- expression (extended_indexoperators.ml[23,436+10]..[23,436+12])
- Pexp_ident "#?" (extended_indexoperators.ml[23,436+10]..[23,436+12])
- [
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[23,436+8]..[23,436+9])
- Pexp_constant PConst_int (1,None)
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[23,436+13]..[23,436+19])
- Pexp_apply
- expression (extended_indexoperators.ml[23,436+13]..[23,436+19])
- Pexp_ident ".%()" (extended_indexoperators.ml[23,436+13]..[23,436+19]) ghost
- [
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[23,436+13]..[23,436+14])
- Pexp_ident "x" (extended_indexoperators.ml[23,436+13]..[23,436+14])
- <arg>
- Nolabel
- expression (extended_indexoperators.ml[23,436+17]..[23,436+18])
- Pexp_constant PConst_int (0,None)
- ]
- ]
- ]
-]
-
--- /dev/null
+[
+ structure_item (extensions.ml[9,153+0]..[9,153+22])
+ Pstr_extension "foo"
+ [
+ structure_item (extensions.ml[9,153+7]..[9,153+21])
+ Pstr_eval
+ expression (extensions.ml[9,153+7]..[9,153+21])
+ Pexp_let Nonrec
+ [
+ <def>
+ pattern (extensions.ml[9,153+11]..[9,153+12])
+ Ppat_var "x" (extensions.ml[9,153+11]..[9,153+12])
+ expression (extensions.ml[9,153+15]..[9,153+16])
+ Pexp_constant PConst_int (1,None)
+ ]
+ expression (extensions.ml[9,153+20]..[9,153+21])
+ Pexp_ident "x" (extensions.ml[9,153+20]..[9,153+21])
+ ]
+ structure_item (extensions.ml[10,176+0]..[10,176+46])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extensions.ml[10,176+4]..[10,176+46]) ghost
+ Ppat_constraint
+ pattern (extensions.ml[10,176+4]..[10,176+14])
+ Ppat_extension "foo"
+ [
+ structure_item (extensions.ml[10,176+10]..[10,176+13])
+ Pstr_eval
+ expression (extensions.ml[10,176+10]..[10,176+13])
+ Pexp_apply
+ expression (extensions.ml[10,176+11]..[10,176+12])
+ Pexp_ident "+" (extensions.ml[10,176+11]..[10,176+12])
+ [
+ <arg>
+ Nolabel
+ expression (extensions.ml[10,176+10]..[10,176+11])
+ Pexp_constant PConst_int (2,None)
+ <arg>
+ Nolabel
+ expression (extensions.ml[10,176+12]..[10,176+13])
+ Pexp_constant PConst_int (1,None)
+ ]
+ ]
+ core_type (extensions.ml[10,176+17]..[10,176+31])
+ Ptyp_extension "foo"
+ [
+ structure_item (extensions.ml[10,176+23]..[10,176+30])
+ Pstr_eval
+ expression (extensions.ml[10,176+23]..[10,176+30])
+ Pexp_field
+ expression (extensions.ml[10,176+23]..[10,176+26])
+ Pexp_ident "bar" (extensions.ml[10,176+23]..[10,176+26])
+ "baz" (extensions.ml[10,176+27]..[10,176+30])
+ ]
+ expression (extensions.ml[10,176+34]..[10,176+46])
+ Pexp_extension "foo"
+ [
+ structure_item (extensions.ml[10,176+40]..[10,176+45])
+ Pstr_eval
+ expression (extensions.ml[10,176+40]..[10,176+45])
+ Pexp_constant PConst_string("foo",None)
+ ]
+ ]
+ structure_item (extensions.ml[12,224+0]..[12,224+26])
+ Pstr_extension "foo"
+ [
+ structure_item (extensions.ml[12,224+7]..[12,224+24])
+ Pstr_module
+ "M" (extensions.ml[12,224+14]..[12,224+15])
+ module_expr (extensions.ml[12,224+18]..[12,224+24])
+ Pmod_extension "bar"
+ []
+ ]
+ structure_item (extensions.ml[13,251+0]..[13,251+74])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extensions.ml[13,251+4]..[13,251+74]) ghost
+ Ppat_constraint
+ pattern (extensions.ml[13,251+4]..[13,251+23])
+ Ppat_extension "foo"
+ [
+ structure_item (extensions.ml[13,251+10]..[13,251+21])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extensions.ml[13,251+14]..[13,251+16])
+ Ppat_construct "()" (extensions.ml[13,251+14]..[13,251+16])
+ None
+ expression (extensions.ml[13,251+19]..[13,251+21])
+ Pexp_construct "()" (extensions.ml[13,251+19]..[13,251+21])
+ None
+ ]
+ ]
+ core_type (extensions.ml[13,251+26]..[13,251+44])
+ Ptyp_extension "foo"
+ [
+ structure_item (extensions.ml[13,251+32]..[13,251+42])
+ Pstr_type Rec
+ [
+ type_declaration "t" (extensions.ml[13,251+37]..[13,251+38]) (extensions.ml[13,251+32]..[13,251+42])
+ ptype_params =
+ []
+ ptype_cstrs =
+ []
+ ptype_kind =
+ Ptype_abstract
+ ptype_private = Public
+ ptype_manifest =
+ Some
+ core_type (extensions.ml[13,251+41]..[13,251+42])
+ Ptyp_constr "t" (extensions.ml[13,251+41]..[13,251+42])
+ []
+ ]
+ ]
+ expression (extensions.ml[13,251+47]..[13,251+74])
+ Pexp_extension "foo"
+ [
+ structure_item (extensions.ml[13,251+53]..[13,251+73])
+ Pstr_class
+ [
+ class_declaration (extensions.ml[13,251+53]..[13,251+73])
+ pci_virt = Concrete
+ pci_params =
+ []
+ pci_name = "c" (extensions.ml[13,251+59]..[13,251+60])
+ pci_expr =
+ class_expr (extensions.ml[13,251+63]..[13,251+73])
+ Pcl_structure
+ class_structure
+ pattern (extensions.ml[13,251+69]..[13,251+69]) ghost
+ Ppat_any
+ []
+ ]
+ ]
+ ]
+ structure_item (extensions.ml[15,327+0]..[15,327+16])
+ Pstr_extension "foo"
+ core_type (extensions.ml[15,327+8]..[15,327+15])
+ Ptyp_constr "list" (extensions.ml[15,327+11]..[15,327+15])
+ [
+ core_type (extensions.ml[15,327+8]..[15,327+10])
+ Ptyp_var a
+ ]
+ structure_item (extensions.ml[16,344+0]..[16,344+60])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extensions.ml[16,344+4]..[16,344+60]) ghost
+ Ppat_constraint
+ pattern (extensions.ml[16,344+4]..[16,344+19])
+ Ppat_extension "foo"
+ core_type (extensions.ml[16,344+11]..[16,344+17])
+ Ptyp_variant closed=Closed
+ [
+ Rtag "Foo" true
+ []
+ ]
+ None
+ core_type (extensions.ml[16,344+22]..[16,344+37])
+ Ptyp_extension "foo"
+ core_type (extensions.ml[16,344+29]..[16,344+35])
+ Ptyp_arrow
+ Nolabel
+ core_type (extensions.ml[16,344+29]..[16,344+30])
+ Ptyp_constr "t" (extensions.ml[16,344+29]..[16,344+30])
+ []
+ core_type (extensions.ml[16,344+34]..[16,344+35])
+ Ptyp_constr "t" (extensions.ml[16,344+34]..[16,344+35])
+ []
+ expression (extensions.ml[16,344+40]..[16,344+60])
+ Pexp_extension "foo"
+ core_type (extensions.ml[16,344+47]..[16,344+58])
+ Ptyp_object Closed
+ method foo
+ core_type (extensions.ml[16,344+55]..[16,344+56])
+ Ptyp_constr "t" (extensions.ml[16,344+55]..[16,344+56])
+ []
+ ]
+ structure_item (extensions.ml[18,406+0]..[18,406+11])
+ Pstr_extension "foo"
+ pattern (extensions.ml[18,406+8]..[18,406+9])
+ Ppat_any
+ structure_item (extensions.ml[19,418+0]..[19,418+26])
+ Pstr_extension "foo"
+ pattern (extensions.ml[19,418+8]..[19,418+14])
+ Ppat_construct "Some" (extensions.ml[19,418+8]..[19,418+12])
+ Some
+ pattern (extensions.ml[19,418+13]..[19,418+14])
+ Ppat_var "y" (extensions.ml[19,418+13]..[19,418+14])
+ <when>
+ expression (extensions.ml[19,418+20]..[19,418+25])
+ Pexp_apply
+ expression (extensions.ml[19,418+22]..[19,418+23])
+ Pexp_ident ">" (extensions.ml[19,418+22]..[19,418+23])
+ [
+ <arg>
+ Nolabel
+ expression (extensions.ml[19,418+20]..[19,418+21])
+ Pexp_ident "y" (extensions.ml[19,418+20]..[19,418+21])
+ <arg>
+ Nolabel
+ expression (extensions.ml[19,418+24]..[19,418+25])
+ Pexp_constant PConst_int (0,None)
+ ]
+ structure_item (extensions.ml[20,445+0]..[20,445+60])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extensions.ml[20,445+4]..[20,445+60]) ghost
+ Ppat_constraint
+ pattern (extensions.ml[20,445+4]..[20,445+28])
+ Ppat_extension "foo"
+ pattern (extensions.ml[20,445+11]..[20,445+26])
+ Ppat_or
+ pattern (extensions.ml[20,445+12]..[20,445+17])
+ Ppat_construct "Bar" (extensions.ml[20,445+12]..[20,445+15])
+ Some
+ pattern (extensions.ml[20,445+16]..[20,445+17])
+ Ppat_var "x" (extensions.ml[20,445+16]..[20,445+17])
+ pattern (extensions.ml[20,445+20]..[20,445+25])
+ Ppat_construct "Baz" (extensions.ml[20,445+20]..[20,445+23])
+ Some
+ pattern (extensions.ml[20,445+24]..[20,445+25])
+ Ppat_var "x" (extensions.ml[20,445+24]..[20,445+25])
+ core_type (extensions.ml[20,445+31]..[20,445+44])
+ Ptyp_extension "foo"
+ pattern (extensions.ml[20,445+38]..[20,445+42])
+ Ppat_type
+ "bar" (extensions.ml[20,445+39]..[20,445+42])
+ expression (extensions.ml[20,445+47]..[20,445+60])
+ Pexp_extension "foo"
+ pattern (extensions.ml[20,445+54]..[20,445+59])
+ Ppat_record Closed
+ [
+ "x" (extensions.ml[20,445+56]..[20,445+57])
+ pattern (extensions.ml[20,445+56]..[20,445+57])
+ Ppat_var "x" (extensions.ml[20,445+56]..[20,445+57])
+ ]
+ ]
+ structure_item (extensions.ml[22,507+0]..[22,507+26])
+ Pstr_extension "foo"
+ [
+ signature_item (extensions.ml[22,507+8]..[22,507+25])
+ Psig_module "M" (extensions.ml[22,507+15]..[22,507+16])
+ module_type (extensions.ml[22,507+19]..[22,507+25])
+ Pmod_extension "baz"
+ []
+ ]
+ structure_item (extensions.ml[23,534+0]..[25,606+23])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (extensions.ml[23,534+4]..[25,606+23]) ghost
+ Ppat_constraint
+ pattern (extensions.ml[23,534+4]..[23,534+38])
+ Ppat_extension "foo"
+ [
+ signature_item (extensions.ml[23,534+11]..[23,534+36])
+ Psig_include
+ module_type (extensions.ml[23,534+19]..[23,534+36])
+ Pmty_with
+ module_type (extensions.ml[23,534+19]..[23,534+20])
+ Pmty_ident "S" (extensions.ml[23,534+19]..[23,534+20])
+ [
+ Pwith_type "t" (extensions.ml[23,534+31]..[23,534+32])
+ type_declaration "t" (extensions.ml[23,534+31]..[23,534+32]) (extensions.ml[23,534+26]..[23,534+36])
+ ptype_params =
+ []
+ ptype_cstrs =
+ []
+ ptype_kind =
+ Ptype_abstract
+ ptype_private = Public
+ ptype_manifest =
+ Some
+ core_type (extensions.ml[23,534+35]..[23,534+36])
+ Ptyp_constr "t" (extensions.ml[23,534+35]..[23,534+36])
+ []
+ ]
+ ]
+ core_type (extensions.ml[24,573+4]..[24,573+32])
+ Ptyp_extension "foo"
+ [
+ signature_item (extensions.ml[24,573+11]..[24,573+20])
+ Psig_value
+ value_description "x" (extensions.ml[24,573+15]..[24,573+16]) (extensions.ml[24,573+11]..[24,573+20])
+ core_type (extensions.ml[24,573+19]..[24,573+20])
+ Ptyp_constr "t" (extensions.ml[24,573+19]..[24,573+20])
+ []
+ []
+ signature_item (extensions.ml[24,573+22]..[24,573+31])
+ Psig_value
+ value_description "y" (extensions.ml[24,573+26]..[24,573+27]) (extensions.ml[24,573+22]..[24,573+31])
+ core_type (extensions.ml[24,573+30]..[24,573+31])
+ Ptyp_constr "t" (extensions.ml[24,573+30]..[24,573+31])
+ []
+ []
+ ]
+ expression (extensions.ml[25,606+4]..[25,606+23])
+ Pexp_extension "foo"
+ [
+ signature_item (extensions.ml[25,606+11]..[25,606+21])
+ Psig_type Rec
+ [
+ type_declaration "t" (extensions.ml[25,606+16]..[25,606+17]) (extensions.ml[25,606+11]..[25,606+21])
+ ptype_params =
+ []
+ ptype_cstrs =
+ []
+ ptype_kind =
+ Ptype_abstract
+ ptype_private = Public
+ ptype_manifest =
+ Some
+ core_type (extensions.ml[25,606+20]..[25,606+21])
+ Ptyp_constr "t" (extensions.ml[25,606+20]..[25,606+21])
+ []
+ ]
+ ]
+ ]
+]
+
+File "extensions.ml", line 9, characters 3-6:
+Error: Uninterpreted extension 'foo'.
+(* TEST
+ flags = "-dparsetree"
+ ocamlc_byte_exit_status = "2"
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ *** check-ocamlc.byte-output
+*)
[%%foo let x = 1 in x]
let [%foo 2+1] : [%foo bar.baz] = [%foo "foo"]
+++ /dev/null
-[
- structure_item (extensions.ml[2,1+0]..[2,1+22])
- Pstr_extension "foo"
- [
- structure_item (extensions.ml[2,1+7]..[2,1+21])
- Pstr_eval
- expression (extensions.ml[2,1+7]..[2,1+21])
- Pexp_let Nonrec
- [
- <def>
- pattern (extensions.ml[2,1+11]..[2,1+12])
- Ppat_var "x" (extensions.ml[2,1+11]..[2,1+12])
- expression (extensions.ml[2,1+15]..[2,1+16])
- Pexp_constant PConst_int (1,None)
- ]
- expression (extensions.ml[2,1+20]..[2,1+21])
- Pexp_ident "x" (extensions.ml[2,1+20]..[2,1+21])
- ]
- structure_item (extensions.ml[3,24+0]..[3,24+46])
- Pstr_value Nonrec
- [
- <def>
- pattern (extensions.ml[3,24+4]..[3,24+46]) ghost
- Ppat_constraint
- pattern (extensions.ml[3,24+4]..[3,24+14])
- Ppat_extension "foo"
- [
- structure_item (extensions.ml[3,24+10]..[3,24+13])
- Pstr_eval
- expression (extensions.ml[3,24+10]..[3,24+13])
- Pexp_apply
- expression (extensions.ml[3,24+11]..[3,24+12])
- Pexp_ident "+" (extensions.ml[3,24+11]..[3,24+12])
- [
- <arg>
- Nolabel
- expression (extensions.ml[3,24+10]..[3,24+11])
- Pexp_constant PConst_int (2,None)
- <arg>
- Nolabel
- expression (extensions.ml[3,24+12]..[3,24+13])
- Pexp_constant PConst_int (1,None)
- ]
- ]
- core_type (extensions.ml[3,24+17]..[3,24+31])
- Ptyp_extension "foo"
- [
- structure_item (extensions.ml[3,24+23]..[3,24+30])
- Pstr_eval
- expression (extensions.ml[3,24+23]..[3,24+30])
- Pexp_field
- expression (extensions.ml[3,24+23]..[3,24+26])
- Pexp_ident "bar" (extensions.ml[3,24+23]..[3,24+26])
- "baz" (extensions.ml[3,24+27]..[3,24+30])
- ]
- expression (extensions.ml[3,24+34]..[3,24+46])
- Pexp_extension "foo"
- [
- structure_item (extensions.ml[3,24+40]..[3,24+45])
- Pstr_eval
- expression (extensions.ml[3,24+40]..[3,24+45])
- Pexp_constant PConst_string("foo",None)
- ]
- ]
- structure_item (extensions.ml[5,72+0]..[5,72+26])
- Pstr_extension "foo"
- [
- structure_item (extensions.ml[5,72+7]..[5,72+24])
- Pstr_module
- "M" (extensions.ml[5,72+14]..[5,72+15])
- module_expr (extensions.ml[5,72+18]..[5,72+24])
- Pmod_extension "bar"
- []
- ]
- structure_item (extensions.ml[6,99+0]..[6,99+74])
- Pstr_value Nonrec
- [
- <def>
- pattern (extensions.ml[6,99+4]..[6,99+74]) ghost
- Ppat_constraint
- pattern (extensions.ml[6,99+4]..[6,99+23])
- Ppat_extension "foo"
- [
- structure_item (extensions.ml[6,99+10]..[6,99+21])
- Pstr_value Nonrec
- [
- <def>
- pattern (extensions.ml[6,99+14]..[6,99+16])
- Ppat_construct "()" (extensions.ml[6,99+14]..[6,99+16])
- None
- expression (extensions.ml[6,99+19]..[6,99+21])
- Pexp_construct "()" (extensions.ml[6,99+19]..[6,99+21])
- None
- ]
- ]
- core_type (extensions.ml[6,99+26]..[6,99+44])
- Ptyp_extension "foo"
- [
- structure_item (extensions.ml[6,99+32]..[6,99+42])
- Pstr_type Rec
- [
- type_declaration "t" (extensions.ml[6,99+37]..[6,99+38]) (extensions.ml[6,99+32]..[6,99+42])
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_abstract
- ptype_private = Public
- ptype_manifest =
- Some
- core_type (extensions.ml[6,99+41]..[6,99+42])
- Ptyp_constr "t" (extensions.ml[6,99+41]..[6,99+42])
- []
- ]
- ]
- expression (extensions.ml[6,99+47]..[6,99+74])
- Pexp_extension "foo"
- [
- structure_item (extensions.ml[6,99+53]..[6,99+73])
- Pstr_class
- [
- class_declaration (extensions.ml[6,99+53]..[6,99+73])
- pci_virt = Concrete
- pci_params =
- []
- pci_name = "c" (extensions.ml[6,99+59]..[6,99+60])
- pci_expr =
- class_expr (extensions.ml[6,99+63]..[6,99+73])
- Pcl_structure
- class_structure
- pattern (extensions.ml[6,99+69]..[6,99+69]) ghost
- Ppat_any
- []
- ]
- ]
- ]
- structure_item (extensions.ml[8,175+0]..[8,175+16])
- Pstr_extension "foo"
- core_type (extensions.ml[8,175+8]..[8,175+15])
- Ptyp_constr "list" (extensions.ml[8,175+11]..[8,175+15])
- [
- core_type (extensions.ml[8,175+8]..[8,175+10])
- Ptyp_var a
- ]
- structure_item (extensions.ml[9,192+0]..[9,192+60])
- Pstr_value Nonrec
- [
- <def>
- pattern (extensions.ml[9,192+4]..[9,192+60]) ghost
- Ppat_constraint
- pattern (extensions.ml[9,192+4]..[9,192+19])
- Ppat_extension "foo"
- core_type (extensions.ml[9,192+11]..[9,192+17])
- Ptyp_variant closed=Closed
- [
- Rtag "Foo" true
- []
- ]
- None
- core_type (extensions.ml[9,192+22]..[9,192+37])
- Ptyp_extension "foo"
- core_type (extensions.ml[9,192+29]..[9,192+35])
- Ptyp_arrow
- Nolabel
- core_type (extensions.ml[9,192+29]..[9,192+30])
- Ptyp_constr "t" (extensions.ml[9,192+29]..[9,192+30])
- []
- core_type (extensions.ml[9,192+34]..[9,192+35])
- Ptyp_constr "t" (extensions.ml[9,192+34]..[9,192+35])
- []
- expression (extensions.ml[9,192+40]..[9,192+60])
- Pexp_extension "foo"
- core_type (extensions.ml[9,192+47]..[9,192+58])
- Ptyp_object Closed
- method foo
- core_type (extensions.ml[9,192+55]..[9,192+56])
- Ptyp_constr "t" (extensions.ml[9,192+55]..[9,192+56])
- []
- ]
- structure_item (extensions.ml[11,254+0]..[11,254+11])
- Pstr_extension "foo"
- pattern (extensions.ml[11,254+8]..[11,254+9])
- Ppat_any
- structure_item (extensions.ml[12,266+0]..[12,266+26])
- Pstr_extension "foo"
- pattern (extensions.ml[12,266+8]..[12,266+14])
- Ppat_construct "Some" (extensions.ml[12,266+8]..[12,266+12])
- Some
- pattern (extensions.ml[12,266+13]..[12,266+14])
- Ppat_var "y" (extensions.ml[12,266+13]..[12,266+14])
- <when>
- expression (extensions.ml[12,266+20]..[12,266+25])
- Pexp_apply
- expression (extensions.ml[12,266+22]..[12,266+23])
- Pexp_ident ">" (extensions.ml[12,266+22]..[12,266+23])
- [
- <arg>
- Nolabel
- expression (extensions.ml[12,266+20]..[12,266+21])
- Pexp_ident "y" (extensions.ml[12,266+20]..[12,266+21])
- <arg>
- Nolabel
- expression (extensions.ml[12,266+24]..[12,266+25])
- Pexp_constant PConst_int (0,None)
- ]
- structure_item (extensions.ml[13,293+0]..[13,293+60])
- Pstr_value Nonrec
- [
- <def>
- pattern (extensions.ml[13,293+4]..[13,293+60]) ghost
- Ppat_constraint
- pattern (extensions.ml[13,293+4]..[13,293+28])
- Ppat_extension "foo"
- pattern (extensions.ml[13,293+11]..[13,293+26])
- Ppat_or
- pattern (extensions.ml[13,293+12]..[13,293+17])
- Ppat_construct "Bar" (extensions.ml[13,293+12]..[13,293+15])
- Some
- pattern (extensions.ml[13,293+16]..[13,293+17])
- Ppat_var "x" (extensions.ml[13,293+16]..[13,293+17])
- pattern (extensions.ml[13,293+20]..[13,293+25])
- Ppat_construct "Baz" (extensions.ml[13,293+20]..[13,293+23])
- Some
- pattern (extensions.ml[13,293+24]..[13,293+25])
- Ppat_var "x" (extensions.ml[13,293+24]..[13,293+25])
- core_type (extensions.ml[13,293+31]..[13,293+44])
- Ptyp_extension "foo"
- pattern (extensions.ml[13,293+38]..[13,293+42])
- Ppat_type
- "bar" (extensions.ml[13,293+39]..[13,293+42])
- expression (extensions.ml[13,293+47]..[13,293+60])
- Pexp_extension "foo"
- pattern (extensions.ml[13,293+54]..[13,293+59])
- Ppat_record Closed
- [
- "x" (extensions.ml[13,293+56]..[13,293+57])
- pattern (extensions.ml[13,293+56]..[13,293+57])
- Ppat_var "x" (extensions.ml[13,293+56]..[13,293+57])
- ]
- ]
- structure_item (extensions.ml[15,355+0]..[15,355+26])
- Pstr_extension "foo"
- [
- signature_item (extensions.ml[15,355+8]..[15,355+25])
- Psig_module "M" (extensions.ml[15,355+15]..[15,355+16])
- module_type (extensions.ml[15,355+19]..[15,355+25])
- Pmod_extension "baz"
- []
- ]
- structure_item (extensions.ml[16,382+0]..[18,454+23])
- Pstr_value Nonrec
- [
- <def>
- pattern (extensions.ml[16,382+4]..[18,454+23]) ghost
- Ppat_constraint
- pattern (extensions.ml[16,382+4]..[16,382+38])
- Ppat_extension "foo"
- [
- signature_item (extensions.ml[16,382+11]..[16,382+36])
- Psig_include
- module_type (extensions.ml[16,382+19]..[16,382+36])
- Pmty_with
- module_type (extensions.ml[16,382+19]..[16,382+20])
- Pmty_ident "S" (extensions.ml[16,382+19]..[16,382+20])
- [
- Pwith_type "t" (extensions.ml[16,382+31]..[16,382+32])
- type_declaration "t" (extensions.ml[16,382+31]..[16,382+32]) (extensions.ml[16,382+26]..[16,382+36])
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_abstract
- ptype_private = Public
- ptype_manifest =
- Some
- core_type (extensions.ml[16,382+35]..[16,382+36])
- Ptyp_constr "t" (extensions.ml[16,382+35]..[16,382+36])
- []
- ]
- ]
- core_type (extensions.ml[17,421+4]..[17,421+32])
- Ptyp_extension "foo"
- [
- signature_item (extensions.ml[17,421+11]..[17,421+20])
- Psig_value
- value_description "x" (extensions.ml[17,421+15]..[17,421+16]) (extensions.ml[17,421+11]..[17,421+20])
- core_type (extensions.ml[17,421+19]..[17,421+20])
- Ptyp_constr "t" (extensions.ml[17,421+19]..[17,421+20])
- []
- []
- signature_item (extensions.ml[17,421+22]..[17,421+31])
- Psig_value
- value_description "y" (extensions.ml[17,421+26]..[17,421+27]) (extensions.ml[17,421+22]..[17,421+31])
- core_type (extensions.ml[17,421+30]..[17,421+31])
- Ptyp_constr "t" (extensions.ml[17,421+30]..[17,421+31])
- []
- []
- ]
- expression (extensions.ml[18,454+4]..[18,454+23])
- Pexp_extension "foo"
- [
- signature_item (extensions.ml[18,454+11]..[18,454+21])
- Psig_type Rec
- [
- type_declaration "t" (extensions.ml[18,454+16]..[18,454+17]) (extensions.ml[18,454+11]..[18,454+21])
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_abstract
- ptype_private = Public
- ptype_manifest =
- Some
- core_type (extensions.ml[18,454+20]..[18,454+21])
- Ptyp_constr "t" (extensions.ml[18,454+20]..[18,454+21])
- []
- ]
- ]
- ]
-]
-
-File "extensions.ml", line 2, characters 3-6:
-Error: Uninterpreted extension 'foo'.
--- /dev/null
+[
+ structure_item (int_and_float_with_modifier.ml[9,153+0]..[10,184+57])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (int_and_float_with_modifier.ml[9,153+4]..[9,153+28])
+ Ppat_var "int_with_custom_modifier" (int_and_float_with_modifier.ml[9,153+4]..[9,153+28])
+ expression (int_and_float_with_modifier.ml[10,184+2]..[10,184+57])
+ Pexp_constant PConst_int (1234567890_1234567890_1234567890_1234567890_1234567890,Some z)
+ ]
+ structure_item (int_and_float_with_modifier.ml[11,242+0]..[12,275+58])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (int_and_float_with_modifier.ml[11,242+4]..[11,242+30])
+ Ppat_var "float_with_custom_modifier" (int_and_float_with_modifier.ml[11,242+4]..[11,242+30])
+ expression (int_and_float_with_modifier.ml[12,275+2]..[12,275+58])
+ Pexp_constant PConst_float (1234567890_1234567890_1234567890_1234567890_1234567890.,Some z)
+ ]
+ structure_item (int_and_float_with_modifier.ml[14,335+0]..[14,335+21])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (int_and_float_with_modifier.ml[14,335+4]..[14,335+9])
+ Ppat_var "int32" (int_and_float_with_modifier.ml[14,335+4]..[14,335+9])
+ expression (int_and_float_with_modifier.ml[14,335+16]..[14,335+21])
+ Pexp_constant PConst_int (1234,Some l)
+ ]
+ structure_item (int_and_float_with_modifier.ml[15,357+0]..[15,357+21])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (int_and_float_with_modifier.ml[15,357+4]..[15,357+9])
+ Ppat_var "int64" (int_and_float_with_modifier.ml[15,357+4]..[15,357+9])
+ expression (int_and_float_with_modifier.ml[15,357+16]..[15,357+21])
+ Pexp_constant PConst_int (1234,Some L)
+ ]
+ structure_item (int_and_float_with_modifier.ml[16,379+0]..[16,379+21])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (int_and_float_with_modifier.ml[16,379+4]..[16,379+13])
+ Ppat_var "nativeint" (int_and_float_with_modifier.ml[16,379+4]..[16,379+13])
+ expression (int_and_float_with_modifier.ml[16,379+16]..[16,379+21])
+ Pexp_constant PConst_int (1234,Some n)
+ ]
+ structure_item (int_and_float_with_modifier.ml[18,402+0]..[18,402+32])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (int_and_float_with_modifier.ml[18,402+4]..[18,402+24])
+ Ppat_var "hex_without_modifier" (int_and_float_with_modifier.ml[18,402+4]..[18,402+24])
+ expression (int_and_float_with_modifier.ml[18,402+27]..[18,402+32])
+ Pexp_constant PConst_int (0x32f,None)
+ ]
+ structure_item (int_and_float_with_modifier.ml[19,435+0]..[19,435+32])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (int_and_float_with_modifier.ml[19,435+4]..[19,435+21])
+ Ppat_var "hex_with_modifier" (int_and_float_with_modifier.ml[19,435+4]..[19,435+21])
+ expression (int_and_float_with_modifier.ml[19,435+27]..[19,435+32])
+ Pexp_constant PConst_int (0x32,Some g)
+ ]
+ structure_item (int_and_float_with_modifier.ml[21,469+0]..[21,469+33])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (int_and_float_with_modifier.ml[21,469+4]..[21,469+25])
+ Ppat_var "float_without_modifer" (int_and_float_with_modifier.ml[21,469+4]..[21,469+25])
+ expression (int_and_float_with_modifier.ml[21,469+28]..[21,469+33])
+ Pexp_constant PConst_float (1.2e3,None)
+ ]
+ structure_item (int_and_float_with_modifier.ml[22,503+0]..[22,503+32])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (int_and_float_with_modifier.ml[22,503+4]..[22,503+22])
+ Ppat_var "float_with_modifer" (int_and_float_with_modifier.ml[22,503+4]..[22,503+22])
+ expression (int_and_float_with_modifier.ml[22,503+28]..[22,503+32])
+ Pexp_constant PConst_float (1.2,Some g)
+ ]
+]
+
+File "int_and_float_with_modifier.ml", line 10, characters 2-57:
+Error: Unknown modifier 'z' for literal 1234567890_1234567890_1234567890_1234567890_1234567890z
+(* TEST
+ flags = "-dparsetree"
+ ocamlc_byte_exit_status = "2"
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ *** check-ocamlc.byte-output
+*)
+
let int_with_custom_modifier =
1234567890_1234567890_1234567890_1234567890_1234567890z
let float_with_custom_modifier =
+++ /dev/null
-[
- structure_item (int_and_float_with_modifier.ml[1,0+0]..[2,31+57])
- Pstr_value Nonrec
- [
- <def>
- pattern (int_and_float_with_modifier.ml[1,0+4]..[1,0+28])
- Ppat_var "int_with_custom_modifier" (int_and_float_with_modifier.ml[1,0+4]..[1,0+28])
- expression (int_and_float_with_modifier.ml[2,31+2]..[2,31+57])
- Pexp_constant PConst_int (1234567890_1234567890_1234567890_1234567890_1234567890,Some z)
- ]
- structure_item (int_and_float_with_modifier.ml[3,89+0]..[4,122+58])
- Pstr_value Nonrec
- [
- <def>
- pattern (int_and_float_with_modifier.ml[3,89+4]..[3,89+30])
- Ppat_var "float_with_custom_modifier" (int_and_float_with_modifier.ml[3,89+4]..[3,89+30])
- expression (int_and_float_with_modifier.ml[4,122+2]..[4,122+58])
- Pexp_constant PConst_float (1234567890_1234567890_1234567890_1234567890_1234567890.,Some z)
- ]
- structure_item (int_and_float_with_modifier.ml[6,182+0]..[6,182+21])
- Pstr_value Nonrec
- [
- <def>
- pattern (int_and_float_with_modifier.ml[6,182+4]..[6,182+9])
- Ppat_var "int32" (int_and_float_with_modifier.ml[6,182+4]..[6,182+9])
- expression (int_and_float_with_modifier.ml[6,182+16]..[6,182+21])
- Pexp_constant PConst_int (1234,Some l)
- ]
- structure_item (int_and_float_with_modifier.ml[7,204+0]..[7,204+21])
- Pstr_value Nonrec
- [
- <def>
- pattern (int_and_float_with_modifier.ml[7,204+4]..[7,204+9])
- Ppat_var "int64" (int_and_float_with_modifier.ml[7,204+4]..[7,204+9])
- expression (int_and_float_with_modifier.ml[7,204+16]..[7,204+21])
- Pexp_constant PConst_int (1234,Some L)
- ]
- structure_item (int_and_float_with_modifier.ml[8,226+0]..[8,226+21])
- Pstr_value Nonrec
- [
- <def>
- pattern (int_and_float_with_modifier.ml[8,226+4]..[8,226+13])
- Ppat_var "nativeint" (int_and_float_with_modifier.ml[8,226+4]..[8,226+13])
- expression (int_and_float_with_modifier.ml[8,226+16]..[8,226+21])
- Pexp_constant PConst_int (1234,Some n)
- ]
- structure_item (int_and_float_with_modifier.ml[10,249+0]..[10,249+32])
- Pstr_value Nonrec
- [
- <def>
- pattern (int_and_float_with_modifier.ml[10,249+4]..[10,249+24])
- Ppat_var "hex_without_modifier" (int_and_float_with_modifier.ml[10,249+4]..[10,249+24])
- expression (int_and_float_with_modifier.ml[10,249+27]..[10,249+32])
- Pexp_constant PConst_int (0x32f,None)
- ]
- structure_item (int_and_float_with_modifier.ml[11,282+0]..[11,282+32])
- Pstr_value Nonrec
- [
- <def>
- pattern (int_and_float_with_modifier.ml[11,282+4]..[11,282+21])
- Ppat_var "hex_with_modifier" (int_and_float_with_modifier.ml[11,282+4]..[11,282+21])
- expression (int_and_float_with_modifier.ml[11,282+27]..[11,282+32])
- Pexp_constant PConst_int (0x32,Some g)
- ]
- structure_item (int_and_float_with_modifier.ml[13,316+0]..[13,316+33])
- Pstr_value Nonrec
- [
- <def>
- pattern (int_and_float_with_modifier.ml[13,316+4]..[13,316+25])
- Ppat_var "float_without_modifer" (int_and_float_with_modifier.ml[13,316+4]..[13,316+25])
- expression (int_and_float_with_modifier.ml[13,316+28]..[13,316+33])
- Pexp_constant PConst_float (1.2e3,None)
- ]
- structure_item (int_and_float_with_modifier.ml[14,350+0]..[14,350+32])
- Pstr_value Nonrec
- [
- <def>
- pattern (int_and_float_with_modifier.ml[14,350+4]..[14,350+22])
- Ppat_var "float_with_modifer" (int_and_float_with_modifier.ml[14,350+4]..[14,350+22])
- expression (int_and_float_with_modifier.ml[14,350+28]..[14,350+32])
- Pexp_constant PConst_float (1.2,Some g)
- ]
-]
-
-File "int_and_float_with_modifier.ml", line 2, characters 2-57:
-Error: Unknown modifier 'z' for literal 1234567890_1234567890_1234567890_1234567890_1234567890z
--- /dev/null
+attributes.ml
+docstrings.ml
+extended_indexoperators.ml
+extensions.ml
+int_and_float_with_modifier.ml
+pr6604_2.ml
+pr6604_3.ml
+pr6604.ml
+pr6865.ml
+pr7165.ml
+shortcut_ext_attr.ml
--- /dev/null
+File "pr6604.ml", line 9, characters 0-1:
+Error: Syntax error
--- /dev/null
+(* TEST
+ flags = "-dparsetree"
+ ocamlc_byte_exit_status = "2"
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ *** check-ocamlc.byte-output
+*)
+
+#1
--- /dev/null
+File "pr6604_2.ml", line 9, characters 1-2:
+Error: Syntax error
--- /dev/null
+(* TEST
+ flags = "-dparsetree"
+ ocamlc_byte_exit_status = "2"
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ *** check-ocamlc.byte-output
+*)
+
+ #1 "pr6604.ml"
--- /dev/null
+(* TEST
+ flags = "-dparsetree"
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ *** check-ocamlc.byte-output
+*)
+
+# 1 "pr6604.ml"
+
+# 3 "pr6604.ml"
+# 4 "pr6604.ml"
--- /dev/null
+[
+ structure_item (pr6865.ml[9,153+0]..[9,153+14]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (pr6865.ml[9,153+0]..[9,153+14])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (pr6865.ml[9,153+8]..[9,153+9])
+ Ppat_var "x" (pr6865.ml[9,153+8]..[9,153+9])
+ expression (pr6865.ml[9,153+12]..[9,153+14])
+ Pexp_constant PConst_int (42,None)
+ ]
+ ]
+ structure_item (pr6865.ml[10,168+0]..[10,168+25]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (pr6865.ml[10,168+0]..[10,168+25])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (pr6865.ml[10,168+8]..[10,168+9])
+ Ppat_any
+ expression (pr6865.ml[10,168+12]..[10,168+14])
+ Pexp_construct "()" (pr6865.ml[10,168+12]..[10,168+14])
+ None
+ <def>
+ pattern (pr6865.ml[10,168+19]..[10,168+20])
+ Ppat_any
+ expression (pr6865.ml[10,168+23]..[10,168+25])
+ Pexp_construct "()" (pr6865.ml[10,168+23]..[10,168+25])
+ None
+ ]
+ ]
+ structure_item (pr6865.ml[11,194+0]..[11,194+14]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (pr6865.ml[11,194+0]..[11,194+14])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (pr6865.ml[11,194+8]..[11,194+9])
+ Ppat_any
+ expression (pr6865.ml[11,194+12]..[11,194+14])
+ Pexp_construct "()" (pr6865.ml[11,194+12]..[11,194+14])
+ None
+ ]
+ ]
+]
+
+File "pr6865.ml", line 9, characters 4-7:
+Error: Uninterpreted extension 'foo'.
+(* TEST
+ flags = "-dparsetree"
+ ocamlc_byte_exit_status = "2"
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ *** check-ocamlc.byte-output
+*)
+
let%foo x = 42
let%foo _ = () and _ = ()
let%foo _ = ()
+++ /dev/null
-[
- structure_item (pr6865.ml[1,0+0]..[1,0+14]) ghost
- Pstr_extension "foo"
- [
- structure_item (pr6865.ml[1,0+0]..[1,0+14])
- Pstr_value Nonrec
- [
- <def>
- pattern (pr6865.ml[1,0+8]..[1,0+9])
- Ppat_var "x" (pr6865.ml[1,0+8]..[1,0+9])
- expression (pr6865.ml[1,0+12]..[1,0+14])
- Pexp_constant PConst_int (42,None)
- ]
- ]
- structure_item (pr6865.ml[2,15+0]..[2,15+25]) ghost
- Pstr_extension "foo"
- [
- structure_item (pr6865.ml[2,15+0]..[2,15+25])
- Pstr_value Nonrec
- [
- <def>
- pattern (pr6865.ml[2,15+8]..[2,15+9])
- Ppat_any
- expression (pr6865.ml[2,15+12]..[2,15+14])
- Pexp_construct "()" (pr6865.ml[2,15+12]..[2,15+14])
- None
- <def>
- pattern (pr6865.ml[2,15+19]..[2,15+20])
- Ppat_any
- expression (pr6865.ml[2,15+23]..[2,15+25])
- Pexp_construct "()" (pr6865.ml[2,15+23]..[2,15+25])
- None
- ]
- ]
- structure_item (pr6865.ml[3,41+0]..[3,41+14]) ghost
- Pstr_extension "foo"
- [
- structure_item (pr6865.ml[3,41+0]..[3,41+14])
- Pstr_value Nonrec
- [
- <def>
- pattern (pr6865.ml[3,41+8]..[3,41+9])
- Ppat_any
- expression (pr6865.ml[3,41+12]..[3,41+14])
- Pexp_construct "()" (pr6865.ml[3,41+12]..[3,41+14])
- None
- ]
- ]
-]
-
-File "pr6865.ml", line 1, characters 4-7:
-Error: Uninterpreted extension 'foo'.
--- /dev/null
+File "pr7165.ml", line 12, characters 1-23:
+Error: Invalid lexer directive "#9342101923012312312 \"\"": line number out of range
+(* TEST
+ flags = "-dparsetree"
+ ocamlc_byte_exit_status = "2"
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ *** check-ocamlc.byte-output
+*)
+
(* this is a lexer directive with an out-of-bound integer;
it should result in a lexing error instead of an
uncaught exception as in PR#7165 *)
-#9342101923012312312
+#9342101923012312312 ""
+++ /dev/null
-File "pr7165.ml", line 4, characters 0-21:
-Error: Invalid lexer directive "#9342101923012312312": line number out of range
--- /dev/null
+[
+ structure_item (shortcut_ext_attr.ml[9,170+0]..[30,721+31])
+ Pstr_value Nonrec
+ [
+ <def>
+ pattern (shortcut_ext_attr.ml[9,170+4]..[9,170+6])
+ Ppat_construct "()" (shortcut_ext_attr.ml[9,170+4]..[9,170+6])
+ None
+ expression (shortcut_ext_attr.ml[10,179+2]..[30,721+31]) ghost
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[10,179+2]..[30,721+31])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[10,179+2]..[30,721+31])
+ Pexp_let Nonrec
+ [
+ <def>
+ attribute "foo"
+ []
+ pattern (shortcut_ext_attr.ml[10,179+16]..[10,179+17])
+ Ppat_var "x" (shortcut_ext_attr.ml[10,179+16]..[10,179+17])
+ expression (shortcut_ext_attr.ml[10,179+20]..[10,179+21])
+ Pexp_constant PConst_int (3,None)
+ <def>
+ attribute "foo"
+ []
+ pattern (shortcut_ext_attr.ml[11,201+12]..[11,201+13])
+ Ppat_var "y" (shortcut_ext_attr.ml[11,201+12]..[11,201+13])
+ expression (shortcut_ext_attr.ml[11,201+16]..[11,201+17])
+ Pexp_constant PConst_int (4,None)
+ ]
+ expression (shortcut_ext_attr.ml[12,222+2]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[12,222+2]..[12,222+36])
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[12,222+3]..[12,222+35])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[12,222+3]..[12,222+35])
+ attribute "foo"
+ []
+ Pexp_letmodule "M" (shortcut_ext_attr.ml[12,222+24]..[12,222+25])
+ module_expr (shortcut_ext_attr.ml[12,222+28]..[12,222+29])
+ Pmod_ident "M" (shortcut_ext_attr.ml[12,222+28]..[12,222+29])
+ expression (shortcut_ext_attr.ml[12,222+33]..[12,222+35])
+ Pexp_construct "()" (shortcut_ext_attr.ml[12,222+33]..[12,222+35])
+ None
+ ]
+ expression (shortcut_ext_attr.ml[13,261+2]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[13,261+2]..[13,261+30])
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[13,261+3]..[13,261+29])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[13,261+3]..[13,261+29])
+ attribute "foo"
+ []
+ Pexp_open Fresh ""M" (shortcut_ext_attr.ml[13,261+22]..[13,261+23])"
+ expression (shortcut_ext_attr.ml[13,261+27]..[13,261+29])
+ Pexp_construct "()" (shortcut_ext_attr.ml[13,261+27]..[13,261+29])
+ None
+ ]
+ expression (shortcut_ext_attr.ml[14,294+2]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[14,294+2]..[14,294+25])
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[14,294+3]..[14,294+24])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[14,294+3]..[14,294+24])
+ attribute "foo"
+ []
+ Pexp_fun
+ Nolabel
+ None
+ pattern (shortcut_ext_attr.ml[14,294+17]..[14,294+18])
+ Ppat_var "x" (shortcut_ext_attr.ml[14,294+17]..[14,294+18])
+ expression (shortcut_ext_attr.ml[14,294+22]..[14,294+24])
+ Pexp_construct "()" (shortcut_ext_attr.ml[14,294+22]..[14,294+24])
+ None
+ ]
+ expression (shortcut_ext_attr.ml[15,322+2]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[15,322+2]..[15,322+30])
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[15,322+3]..[15,322+29])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[15,322+3]..[15,322+29])
+ attribute "foo"
+ []
+ Pexp_function
+ [
+ <case>
+ pattern (shortcut_ext_attr.ml[15,322+22]..[15,322+23])
+ Ppat_var "x" (shortcut_ext_attr.ml[15,322+22]..[15,322+23])
+ expression (shortcut_ext_attr.ml[15,322+27]..[15,322+29])
+ Pexp_construct "()" (shortcut_ext_attr.ml[15,322+27]..[15,322+29])
+ None
+ ]
+ ]
+ expression (shortcut_ext_attr.ml[16,355+2]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[16,355+2]..[16,355+33])
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[16,355+3]..[16,355+32])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[16,355+3]..[16,355+32])
+ attribute "foo"
+ []
+ Pexp_try
+ expression (shortcut_ext_attr.ml[16,355+17]..[16,355+19])
+ Pexp_construct "()" (shortcut_ext_attr.ml[16,355+17]..[16,355+19])
+ None
+ [
+ <case>
+ pattern (shortcut_ext_attr.ml[16,355+25]..[16,355+26])
+ Ppat_any
+ expression (shortcut_ext_attr.ml[16,355+30]..[16,355+32])
+ Pexp_construct "()" (shortcut_ext_attr.ml[16,355+30]..[16,355+32])
+ None
+ ]
+ ]
+ expression (shortcut_ext_attr.ml[17,391+2]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[17,391+2]..[17,391+35])
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[17,391+3]..[17,391+34])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[17,391+3]..[17,391+34])
+ attribute "foo"
+ []
+ Pexp_ifthenelse
+ expression (shortcut_ext_attr.ml[17,391+16]..[17,391+18])
+ Pexp_construct "()" (shortcut_ext_attr.ml[17,391+16]..[17,391+18])
+ None
+ expression (shortcut_ext_attr.ml[17,391+24]..[17,391+26])
+ Pexp_construct "()" (shortcut_ext_attr.ml[17,391+24]..[17,391+26])
+ None
+ Some
+ expression (shortcut_ext_attr.ml[17,391+32]..[17,391+34])
+ Pexp_construct "()" (shortcut_ext_attr.ml[17,391+32]..[17,391+34])
+ None
+ ]
+ expression (shortcut_ext_attr.ml[18,429+2]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[18,429+2]..[18,429+31]) ghost
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[18,429+2]..[18,429+31])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[18,429+2]..[18,429+31])
+ attribute "foo"
+ []
+ Pexp_while
+ expression (shortcut_ext_attr.ml[18,429+18]..[18,429+20])
+ Pexp_construct "()" (shortcut_ext_attr.ml[18,429+18]..[18,429+20])
+ None
+ expression (shortcut_ext_attr.ml[18,429+24]..[18,429+26])
+ Pexp_construct "()" (shortcut_ext_attr.ml[18,429+24]..[18,429+26])
+ None
+ ]
+ expression (shortcut_ext_attr.ml[19,463+2]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[19,463+2]..[19,463+39]) ghost
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[19,463+2]..[19,463+39])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[19,463+2]..[19,463+39])
+ attribute "foo"
+ []
+ Pexp_for Up
+ pattern (shortcut_ext_attr.ml[19,463+16]..[19,463+17])
+ Ppat_var "x" (shortcut_ext_attr.ml[19,463+16]..[19,463+17])
+ expression (shortcut_ext_attr.ml[19,463+20]..[19,463+22])
+ Pexp_construct "()" (shortcut_ext_attr.ml[19,463+20]..[19,463+22])
+ None
+ expression (shortcut_ext_attr.ml[19,463+26]..[19,463+28])
+ Pexp_construct "()" (shortcut_ext_attr.ml[19,463+26]..[19,463+28])
+ None
+ expression (shortcut_ext_attr.ml[19,463+32]..[19,463+34])
+ Pexp_construct "()" (shortcut_ext_attr.ml[19,463+32]..[19,463+34])
+ None
+ ]
+ expression (shortcut_ext_attr.ml[20,505+2]..[30,721+31])
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[20,505+2]..[30,721+31])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[20,505+2]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[20,505+2]..[20,505+4])
+ Pexp_construct "()" (shortcut_ext_attr.ml[20,505+2]..[20,505+4])
+ None
+ expression (shortcut_ext_attr.ml[20,505+11]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[20,505+11]..[20,505+13])
+ Pexp_construct "()" (shortcut_ext_attr.ml[20,505+11]..[20,505+13])
+ None
+ expression (shortcut_ext_attr.ml[21,521+2]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[21,521+2]..[21,521+23]) ghost
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[21,521+2]..[21,521+23])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[21,521+2]..[21,521+23])
+ attribute "foo"
+ []
+ Pexp_assert
+ expression (shortcut_ext_attr.ml[21,521+19]..[21,521+23])
+ Pexp_construct "true" (shortcut_ext_attr.ml[21,521+19]..[21,521+23])
+ None
+ ]
+ expression (shortcut_ext_attr.ml[22,547+2]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[22,547+2]..[22,547+18]) ghost
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[22,547+2]..[22,547+18])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[22,547+2]..[22,547+18])
+ attribute "foo"
+ []
+ Pexp_lazy
+ expression (shortcut_ext_attr.ml[22,547+17]..[22,547+18])
+ Pexp_ident "x" (shortcut_ext_attr.ml[22,547+17]..[22,547+18])
+ ]
+ expression (shortcut_ext_attr.ml[23,568+2]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[23,568+2]..[23,568+22]) ghost
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[23,568+2]..[23,568+22])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[23,568+2]..[23,568+22])
+ attribute "foo"
+ []
+ Pexp_object
+ class_structure
+ pattern (shortcut_ext_attr.ml[23,568+18]..[23,568+18]) ghost
+ Ppat_any
+ []
+ ]
+ expression (shortcut_ext_attr.ml[24,593+2]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[24,593+2]..[24,593+23]) ghost
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[24,593+2]..[24,593+23])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[24,593+2]..[24,593+23])
+ attribute "foo"
+ []
+ Pexp_constant PConst_int (3,None)
+ ]
+ expression (shortcut_ext_attr.ml[25,619+2]..[30,721+31])
+ Pexp_sequence
+ expression (shortcut_ext_attr.ml[25,619+2]..[25,619+17]) ghost
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[25,619+2]..[25,619+17])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[25,619+2]..[25,619+17])
+ attribute "foo"
+ []
+ Pexp_new "x" (shortcut_ext_attr.ml[25,619+16]..[25,619+17])
+ ]
+ expression (shortcut_ext_attr.ml[27,640+2]..[30,721+31]) ghost
+ Pexp_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[27,640+2]..[30,721+31])
+ Pstr_eval
+ expression (shortcut_ext_attr.ml[27,640+2]..[30,721+31])
+ attribute "foo"
+ []
+ Pexp_match
+ expression (shortcut_ext_attr.ml[27,640+18]..[27,640+20])
+ Pexp_construct "()" (shortcut_ext_attr.ml[27,640+18]..[27,640+20])
+ None
+ [
+ <case>
+ pattern (shortcut_ext_attr.ml[29,694+4]..[29,694+20]) ghost
+ Ppat_extension "foo"
+ pattern (shortcut_ext_attr.ml[29,694+4]..[29,694+20])
+ attribute "foo"
+ []
+ Ppat_lazy
+ pattern (shortcut_ext_attr.ml[29,694+19]..[29,694+20])
+ Ppat_var "x" (shortcut_ext_attr.ml[29,694+19]..[29,694+20])
+ expression (shortcut_ext_attr.ml[29,694+24]..[29,694+26])
+ Pexp_construct "()" (shortcut_ext_attr.ml[29,694+24]..[29,694+26])
+ None
+ <case>
+ pattern (shortcut_ext_attr.ml[30,721+4]..[30,721+25]) ghost
+ Ppat_extension "foo"
+ pattern (shortcut_ext_attr.ml[30,721+4]..[30,721+25])
+ attribute "foo"
+ []
+ Ppat_exception
+ pattern (shortcut_ext_attr.ml[30,721+24]..[30,721+25])
+ Ppat_var "x" (shortcut_ext_attr.ml[30,721+24]..[30,721+25])
+ expression (shortcut_ext_attr.ml[30,721+29]..[30,721+31])
+ Pexp_construct "()" (shortcut_ext_attr.ml[30,721+29]..[30,721+31])
+ None
+ ]
+ ]
+ ]
+ ]
+ ]
+ structure_item (shortcut_ext_attr.ml[34,779+0]..[46,1049+5])
+ Pstr_class
+ [
+ class_declaration (shortcut_ext_attr.ml[34,779+0]..[46,1049+5])
+ pci_virt = Concrete
+ pci_params =
+ []
+ pci_name = "x" (shortcut_ext_attr.ml[34,779+6]..[34,779+7])
+ pci_expr =
+ class_expr (shortcut_ext_attr.ml[35,789+12]..[46,1049+5])
+ attribute "foo"
+ []
+ Pcl_fun
+ Nolabel
+ None
+ pattern (shortcut_ext_attr.ml[35,789+12]..[35,789+13])
+ Ppat_var "x" (shortcut_ext_attr.ml[35,789+12]..[35,789+13])
+ class_expr (shortcut_ext_attr.ml[36,806+2]..[46,1049+5])
+ Pcl_let Nonrec
+ [
+ <def>
+ attribute "foo"
+ []
+ pattern (shortcut_ext_attr.ml[36,806+12]..[36,806+13])
+ Ppat_var "x" (shortcut_ext_attr.ml[36,806+12]..[36,806+13])
+ expression (shortcut_ext_attr.ml[36,806+16]..[36,806+17])
+ Pexp_constant PConst_int (3,None)
+ ]
+ class_expr (shortcut_ext_attr.ml[37,827+2]..[46,1049+5])
+ attribute "foo"
+ []
+ Pcl_structure
+ class_structure
+ pattern (shortcut_ext_attr.ml[37,827+14]..[37,827+14]) ghost
+ Ppat_any
+ [
+ class_field (shortcut_ext_attr.ml[38,842+4]..[38,842+19])
+ attribute "foo"
+ []
+ Pcf_inherit Fresh
+ class_expr (shortcut_ext_attr.ml[38,842+18]..[38,842+19])
+ Pcl_constr "x" (shortcut_ext_attr.ml[38,842+18]..[38,842+19])
+ []
+ None
+ class_field (shortcut_ext_attr.ml[39,862+4]..[39,862+19])
+ attribute "foo"
+ []
+ Pcf_val Immutable
+ "x" (shortcut_ext_attr.ml[39,862+14]..[39,862+15])
+ Concrete Fresh
+ expression (shortcut_ext_attr.ml[39,862+18]..[39,862+19])
+ Pexp_constant PConst_int (3,None)
+ class_field (shortcut_ext_attr.ml[40,882+4]..[40,882+27])
+ attribute "foo"
+ []
+ Pcf_val Immutable
+ "x" (shortcut_ext_attr.ml[40,882+22]..[40,882+23])
+ Virtual
+ core_type (shortcut_ext_attr.ml[40,882+26]..[40,882+27])
+ Ptyp_constr "t" (shortcut_ext_attr.ml[40,882+26]..[40,882+27])
+ []
+ class_field (shortcut_ext_attr.ml[41,910+4]..[41,910+28])
+ attribute "foo"
+ []
+ Pcf_val Mutable
+ "x" (shortcut_ext_attr.ml[41,910+23]..[41,910+24])
+ Concrete Override
+ expression (shortcut_ext_attr.ml[41,910+27]..[41,910+28])
+ Pexp_constant PConst_int (3,None)
+ class_field (shortcut_ext_attr.ml[42,939+4]..[42,939+22])
+ attribute "foo"
+ []
+ Pcf_method Public
+ "x" (shortcut_ext_attr.ml[42,939+17]..[42,939+18])
+ Concrete Fresh
+ expression (shortcut_ext_attr.ml[42,939+10]..[42,939+22]) ghost
+ Pexp_poly
+ expression (shortcut_ext_attr.ml[42,939+21]..[42,939+22])
+ Pexp_constant PConst_int (3,None)
+ None
+ class_field (shortcut_ext_attr.ml[43,962+4]..[43,962+30])
+ attribute "foo"
+ []
+ Pcf_method Public
+ "x" (shortcut_ext_attr.ml[43,962+25]..[43,962+26])
+ Virtual
+ core_type (shortcut_ext_attr.ml[43,962+29]..[43,962+30])
+ Ptyp_constr "t" (shortcut_ext_attr.ml[43,962+29]..[43,962+30])
+ []
+ class_field (shortcut_ext_attr.ml[44,993+4]..[44,993+31])
+ attribute "foo"
+ []
+ Pcf_method Private
+ "x" (shortcut_ext_attr.ml[44,993+26]..[44,993+27])
+ Concrete Override
+ expression (shortcut_ext_attr.ml[44,993+10]..[44,993+31]) ghost
+ Pexp_poly
+ expression (shortcut_ext_attr.ml[44,993+30]..[44,993+31])
+ Pexp_constant PConst_int (3,None)
+ None
+ class_field (shortcut_ext_attr.ml[45,1025+4]..[45,1025+23])
+ attribute "foo"
+ []
+ Pcf_initializer
+ expression (shortcut_ext_attr.ml[45,1025+22]..[45,1025+23])
+ Pexp_ident "x" (shortcut_ext_attr.ml[45,1025+22]..[45,1025+23])
+ ]
+ ]
+ structure_item (shortcut_ext_attr.ml[49,1085+0]..[57,1265+5])
+ Pstr_class_type
+ [
+ class_type_declaration (shortcut_ext_attr.ml[49,1085+0]..[57,1265+5])
+ pci_virt = Concrete
+ pci_params =
+ []
+ pci_name = "t" (shortcut_ext_attr.ml[49,1085+11]..[49,1085+12])
+ pci_expr =
+ class_type (shortcut_ext_attr.ml[50,1100+2]..[57,1265+5])
+ attribute "foo"
+ []
+ Pcty_signature
+ class_signature
+ core_type (shortcut_ext_attr.ml[50,1100+14]..[50,1100+14])
+ Ptyp_any
+ [
+ class_type_field (shortcut_ext_attr.ml[51,1115+4]..[51,1115+19])
+ attribute "foo"
+ []
+ Pctf_inherit
+ class_type (shortcut_ext_attr.ml[51,1115+18]..[51,1115+19])
+ Pcty_constr "t" (shortcut_ext_attr.ml[51,1115+18]..[51,1115+19])
+ []
+ class_type_field (shortcut_ext_attr.ml[52,1135+4]..[52,1135+19])
+ attribute "foo"
+ []
+ Pctf_val "x" Immutable Concrete
+ core_type (shortcut_ext_attr.ml[52,1135+18]..[52,1135+19])
+ Ptyp_constr "t" (shortcut_ext_attr.ml[52,1135+18]..[52,1135+19])
+ []
+ class_type_field (shortcut_ext_attr.ml[53,1155+4]..[53,1155+27])
+ attribute "foo"
+ []
+ Pctf_val "x" Mutable Concrete
+ core_type (shortcut_ext_attr.ml[53,1155+26]..[53,1155+27])
+ Ptyp_constr "t" (shortcut_ext_attr.ml[53,1155+26]..[53,1155+27])
+ []
+ class_type_field (shortcut_ext_attr.ml[54,1183+4]..[54,1183+22])
+ attribute "foo"
+ []
+ Pctf_method "x" Public Concrete
+ core_type (shortcut_ext_attr.ml[54,1183+21]..[54,1183+22])
+ Ptyp_constr "t" (shortcut_ext_attr.ml[54,1183+21]..[54,1183+22])
+ []
+ class_type_field (shortcut_ext_attr.ml[55,1206+4]..[55,1206+30])
+ attribute "foo"
+ []
+ Pctf_method "x" Private Concrete
+ core_type (shortcut_ext_attr.ml[55,1206+29]..[55,1206+30])
+ Ptyp_constr "t" (shortcut_ext_attr.ml[55,1206+29]..[55,1206+30])
+ []
+ class_type_field (shortcut_ext_attr.ml[56,1237+4]..[56,1237+27])
+ attribute "foo"
+ []
+ Pctf_constraint
+ core_type (shortcut_ext_attr.ml[56,1237+21]..[56,1237+22])
+ Ptyp_constr "t" (shortcut_ext_attr.ml[56,1237+21]..[56,1237+22])
+ []
+ core_type (shortcut_ext_attr.ml[56,1237+25]..[56,1237+27])
+ Ptyp_constr "t'" (shortcut_ext_attr.ml[56,1237+25]..[56,1237+27])
+ []
+ ]
+ ]
+ structure_item (shortcut_ext_attr.ml[60,1295+0]..[61,1304+22])
+ Pstr_type Rec
+ [
+ type_declaration "t" (shortcut_ext_attr.ml[60,1295+5]..[60,1295+6]) (shortcut_ext_attr.ml[60,1295+0]..[61,1304+22])
+ ptype_params =
+ []
+ ptype_cstrs =
+ []
+ ptype_kind =
+ Ptype_abstract
+ ptype_private = Public
+ ptype_manifest =
+ Some
+ core_type (shortcut_ext_attr.ml[61,1304+2]..[61,1304+22]) ghost
+ Ptyp_extension "foo"
+ core_type (shortcut_ext_attr.ml[61,1304+2]..[61,1304+22])
+ attribute "foo"
+ []
+ Ptyp_package "M" (shortcut_ext_attr.ml[61,1304+20]..[61,1304+21])
+ []
+ ]
+ structure_item (shortcut_ext_attr.ml[64,1353+0]..[67,1409+22])
+ Pstr_module
+ "M" (shortcut_ext_attr.ml[64,1353+7]..[64,1353+8])
+ module_expr (shortcut_ext_attr.ml[65,1364+2]..[67,1409+22])
+ attribute "foo"
+ []
+ Pmod_functor "M" (shortcut_ext_attr.ml[65,1364+17]..[65,1364+18])
+ module_type (shortcut_ext_attr.ml[65,1364+21]..[65,1364+22])
+ Pmty_ident "S" (shortcut_ext_attr.ml[65,1364+21]..[65,1364+22])
+ module_expr (shortcut_ext_attr.ml[66,1391+4]..[67,1409+22])
+ Pmod_apply
+ module_expr (shortcut_ext_attr.ml[66,1391+4]..[66,1391+17])
+ attribute "foo"
+ []
+ Pmod_unpack
+ expression (shortcut_ext_attr.ml[66,1391+15]..[66,1391+16])
+ Pexp_ident "x" (shortcut_ext_attr.ml[66,1391+15]..[66,1391+16])
+ module_expr (shortcut_ext_attr.ml[67,1409+5]..[67,1409+21])
+ attribute "foo"
+ []
+ Pmod_structure
+ []
+ structure_item (shortcut_ext_attr.ml[70,1462+0]..[73,1535+19])
+ Pstr_modtype "S" (shortcut_ext_attr.ml[70,1462+12]..[70,1462+13])
+ module_type (shortcut_ext_attr.ml[71,1478+2]..[73,1535+19])
+ attribute "foo"
+ []
+ Pmty_functor "M" (shortcut_ext_attr.ml[71,1478+17]..[71,1478+18])
+ module_type (shortcut_ext_attr.ml[71,1478+19]..[71,1478+20])
+ Pmty_ident "S" (shortcut_ext_attr.ml[71,1478+19]..[71,1478+20])
+ module_type (shortcut_ext_attr.ml[72,1503+4]..[73,1535+19])
+ Pmty_functor "_" (_none_[1,0+-1]..[1,0+-1]) ghost
+ module_type (shortcut_ext_attr.ml[72,1503+5]..[72,1503+27])
+ attribute "foo"
+ []
+ Pmty_typeof
+ module_expr (shortcut_ext_attr.ml[72,1503+26]..[72,1503+27])
+ Pmod_ident "M" (shortcut_ext_attr.ml[72,1503+26]..[72,1503+27])
+ module_type (shortcut_ext_attr.ml[73,1535+5]..[73,1535+18])
+ attribute "foo"
+ []
+ Pmty_signature
+ []
+ structure_item (shortcut_ext_attr.ml[76,1578+0]..[77,1598+15]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[76,1578+0]..[77,1598+15])
+ Pstr_value Nonrec
+ [
+ <def>
+ attribute "foo"
+ []
+ pattern (shortcut_ext_attr.ml[76,1578+14]..[76,1578+15])
+ Ppat_var "x" (shortcut_ext_attr.ml[76,1578+14]..[76,1578+15])
+ expression (shortcut_ext_attr.ml[76,1578+18]..[76,1578+19])
+ Pexp_constant PConst_int (4,None)
+ <def>
+ attribute "foo"
+ []
+ pattern (shortcut_ext_attr.ml[77,1598+10]..[77,1598+11])
+ Ppat_var "y" (shortcut_ext_attr.ml[77,1598+10]..[77,1598+11])
+ expression (shortcut_ext_attr.ml[77,1598+14]..[77,1598+15])
+ Pexp_ident "x" (shortcut_ext_attr.ml[77,1598+14]..[77,1598+15])
+ ]
+ ]
+ structure_item (shortcut_ext_attr.ml[79,1615+0]..[80,1638+17]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[79,1615+0]..[80,1638+17])
+ Pstr_type Rec
+ [
+ type_declaration "t" (shortcut_ext_attr.ml[79,1615+15]..[79,1615+16]) (shortcut_ext_attr.ml[79,1615+0]..[79,1615+22])
+ attribute "foo"
+ []
+ ptype_params =
+ []
+ ptype_cstrs =
+ []
+ ptype_kind =
+ Ptype_abstract
+ ptype_private = Public
+ ptype_manifest =
+ Some
+ core_type (shortcut_ext_attr.ml[79,1615+19]..[79,1615+22])
+ Ptyp_constr "int" (shortcut_ext_attr.ml[79,1615+19]..[79,1615+22])
+ []
+ type_declaration "t" (shortcut_ext_attr.ml[80,1638+10]..[80,1638+11]) (shortcut_ext_attr.ml[80,1638+0]..[80,1638+17])
+ attribute "foo"
+ []
+ ptype_params =
+ []
+ ptype_cstrs =
+ []
+ ptype_kind =
+ Ptype_abstract
+ ptype_private = Public
+ ptype_manifest =
+ Some
+ core_type (shortcut_ext_attr.ml[80,1638+14]..[80,1638+17])
+ Ptyp_constr "int" (shortcut_ext_attr.ml[80,1638+14]..[80,1638+17])
+ []
+ ]
+ ]
+ structure_item (shortcut_ext_attr.ml[81,1656+0]..[81,1656+21]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[81,1656+0]..[81,1656+21])
+ Pstr_typext
+ type_extension
+ attribute "foo"
+ []
+ ptyext_path = "t" (shortcut_ext_attr.ml[81,1656+15]..[81,1656+16])
+ ptyext_params =
+ []
+ ptyext_constructors =
+ [
+ extension_constructor (shortcut_ext_attr.ml[81,1656+20]..[81,1656+21])
+ pext_name = "T"
+ pext_kind =
+ Pext_decl
+ []
+ None
+ ]
+ ptyext_private = Public
+ ]
+ structure_item (shortcut_ext_attr.ml[83,1679+0]..[83,1679+21]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[83,1679+0]..[83,1679+21])
+ Pstr_class
+ [
+ class_declaration (shortcut_ext_attr.ml[83,1679+0]..[83,1679+21])
+ attribute "foo"
+ []
+ pci_virt = Concrete
+ pci_params =
+ []
+ pci_name = "x" (shortcut_ext_attr.ml[83,1679+16]..[83,1679+17])
+ pci_expr =
+ class_expr (shortcut_ext_attr.ml[83,1679+20]..[83,1679+21])
+ Pcl_constr "x" (shortcut_ext_attr.ml[83,1679+20]..[83,1679+21])
+ []
+ ]
+ ]
+ structure_item (shortcut_ext_attr.ml[84,1701+0]..[84,1701+26]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[84,1701+0]..[84,1701+26])
+ Pstr_class_type
+ [
+ class_type_declaration (shortcut_ext_attr.ml[84,1701+0]..[84,1701+26])
+ attribute "foo"
+ []
+ pci_virt = Concrete
+ pci_params =
+ []
+ pci_name = "x" (shortcut_ext_attr.ml[84,1701+21]..[84,1701+22])
+ pci_expr =
+ class_type (shortcut_ext_attr.ml[84,1701+25]..[84,1701+26])
+ Pcty_constr "x" (shortcut_ext_attr.ml[84,1701+25]..[84,1701+26])
+ []
+ ]
+ ]
+ structure_item (shortcut_ext_attr.ml[85,1728+0]..[85,1728+30]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[85,1728+0]..[85,1728+30])
+ Pstr_primitive
+ value_description "x" (shortcut_ext_attr.ml[85,1728+19]..[85,1728+20]) (shortcut_ext_attr.ml[85,1728+0]..[85,1728+30])
+ attribute "foo"
+ []
+ core_type (shortcut_ext_attr.ml[85,1728+23]..[85,1728+24])
+ Ptyp_any
+ [
+ ""
+ ]
+ ]
+ structure_item (shortcut_ext_attr.ml[86,1759+0]..[86,1759+21]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[86,1759+0]..[86,1759+21])
+ Pstr_exception
+ extension_constructor (shortcut_ext_attr.ml[86,1759+0]..[86,1759+21])
+ attribute "foo"
+ []
+ pext_name = "X"
+ pext_kind =
+ Pext_decl
+ []
+ None
+ ]
+ structure_item (shortcut_ext_attr.ml[88,1782+0]..[88,1782+22]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[88,1782+0]..[88,1782+22])
+ Pstr_module
+ "M" (shortcut_ext_attr.ml[88,1782+17]..[88,1782+18])
+ attribute "foo"
+ []
+ module_expr (shortcut_ext_attr.ml[88,1782+21]..[88,1782+22])
+ Pmod_ident "M" (shortcut_ext_attr.ml[88,1782+21]..[88,1782+22])
+ ]
+ structure_item (shortcut_ext_attr.ml[89,1805+0]..[90,1836+19]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[89,1805+0]..[90,1836+19])
+ Pstr_recmodule
+ [
+ "M" (shortcut_ext_attr.ml[89,1805+21]..[89,1805+22])
+ attribute "foo"
+ []
+ module_expr (shortcut_ext_attr.ml[89,1805+23]..[89,1805+30])
+ Pmod_constraint
+ module_expr (shortcut_ext_attr.ml[89,1805+29]..[89,1805+30])
+ Pmod_ident "M" (shortcut_ext_attr.ml[89,1805+29]..[89,1805+30])
+ module_type (shortcut_ext_attr.ml[89,1805+25]..[89,1805+26])
+ Pmty_ident "S" (shortcut_ext_attr.ml[89,1805+25]..[89,1805+26])
+ "M" (shortcut_ext_attr.ml[90,1836+10]..[90,1836+11])
+ attribute "foo"
+ []
+ module_expr (shortcut_ext_attr.ml[90,1836+12]..[90,1836+19])
+ Pmod_constraint
+ module_expr (shortcut_ext_attr.ml[90,1836+18]..[90,1836+19])
+ Pmod_ident "M" (shortcut_ext_attr.ml[90,1836+18]..[90,1836+19])
+ module_type (shortcut_ext_attr.ml[90,1836+14]..[90,1836+15])
+ Pmty_ident "S" (shortcut_ext_attr.ml[90,1836+14]..[90,1836+15])
+ ]
+ ]
+ structure_item (shortcut_ext_attr.ml[91,1856+0]..[91,1856+27]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[91,1856+0]..[91,1856+27])
+ Pstr_modtype "S" (shortcut_ext_attr.ml[91,1856+22]..[91,1856+23])
+ attribute "foo"
+ []
+ module_type (shortcut_ext_attr.ml[91,1856+26]..[91,1856+27])
+ Pmty_ident "S" (shortcut_ext_attr.ml[91,1856+26]..[91,1856+27])
+ ]
+ structure_item (shortcut_ext_attr.ml[93,1885+0]..[93,1885+19]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[93,1885+0]..[93,1885+19])
+ Pstr_include attribute "foo"
+ []
+ module_expr (shortcut_ext_attr.ml[93,1885+18]..[93,1885+19])
+ Pmod_ident "M" (shortcut_ext_attr.ml[93,1885+18]..[93,1885+19])
+ ]
+ structure_item (shortcut_ext_attr.ml[94,1905+0]..[94,1905+16]) ghost
+ Pstr_extension "foo"
+ [
+ structure_item (shortcut_ext_attr.ml[94,1905+0]..[94,1905+16])
+ Pstr_open Fresh "M" (shortcut_ext_attr.ml[94,1905+15]..[94,1905+16])
+ attribute "foo"
+ []
+ ]
+ structure_item (shortcut_ext_attr.ml[97,1945+0]..[120,2341+3])
+ Pstr_modtype "S" (shortcut_ext_attr.ml[97,1945+12]..[97,1945+13])
+ module_type (shortcut_ext_attr.ml[97,1945+16]..[120,2341+3])
+ Pmty_signature
+ [
+ signature_item (shortcut_ext_attr.ml[98,1965+2]..[98,1965+21]) ghost
+ Psig_extension "foo"
+ [
+ signature_item (shortcut_ext_attr.ml[98,1965+2]..[98,1965+21])
+ Psig_value
+ value_description "x" (shortcut_ext_attr.ml[98,1965+16]..[98,1965+17]) (shortcut_ext_attr.ml[98,1965+2]..[98,1965+21])
+ attribute "foo"
+ []
+ core_type (shortcut_ext_attr.ml[98,1965+20]..[98,1965+21])
+ Ptyp_constr "t" (shortcut_ext_attr.ml[98,1965+20]..[98,1965+21])
+ []
+ []
+ ]
+ signature_item (shortcut_ext_attr.ml[99,1987+2]..[99,1987+31]) ghost
+ Psig_extension "foo"
+ [
+ signature_item (shortcut_ext_attr.ml[99,1987+2]..[99,1987+31])
+ Psig_value
+ value_description "x" (shortcut_ext_attr.ml[99,1987+21]..[99,1987+22]) (shortcut_ext_attr.ml[99,1987+2]..[99,1987+31])
+ attribute "foo"
+ []
+ core_type (shortcut_ext_attr.ml[99,1987+25]..[99,1987+26])
+ Ptyp_constr "t" (shortcut_ext_attr.ml[99,1987+25]..[99,1987+26])
+ []
+ [
+ ""
+ ]
+ ]
+ signature_item (shortcut_ext_attr.ml[101,2020+2]..[102,2045+20]) ghost
+ Psig_extension "foo"
+ [
+ signature_item (shortcut_ext_attr.ml[101,2020+2]..[102,2045+20])
+ Psig_type Rec
+ [
+ type_declaration "t" (shortcut_ext_attr.ml[101,2020+17]..[101,2020+18]) (shortcut_ext_attr.ml[101,2020+2]..[101,2020+24])
+ attribute "foo"
+ []
+ ptype_params =
+ []
+ ptype_cstrs =
+ []
+ ptype_kind =
+ Ptype_abstract
+ ptype_private = Public
+ ptype_manifest =
+ Some
+ core_type (shortcut_ext_attr.ml[101,2020+21]..[101,2020+24])
+ Ptyp_constr "int" (shortcut_ext_attr.ml[101,2020+21]..[101,2020+24])
+ []
+ type_declaration "t'" (shortcut_ext_attr.ml[102,2045+12]..[102,2045+14]) (shortcut_ext_attr.ml[102,2045+2]..[102,2045+20])
+ attribute "foo"
+ []
+ ptype_params =
+ []
+ ptype_cstrs =
+ []
+ ptype_kind =
+ Ptype_abstract
+ ptype_private = Public
+ ptype_manifest =
+ Some
+ core_type (shortcut_ext_attr.ml[102,2045+17]..[102,2045+20])
+ Ptyp_constr "int" (shortcut_ext_attr.ml[102,2045+17]..[102,2045+20])
+ []
+ ]
+ ]
+ signature_item (shortcut_ext_attr.ml[103,2066+2]..[103,2066+23]) ghost
+ Psig_extension "foo"
+ [
+ signature_item (shortcut_ext_attr.ml[103,2066+2]..[103,2066+23])
+ Psig_typext
+ type_extension
+ attribute "foo"
+ []
+ ptyext_path = "t" (shortcut_ext_attr.ml[103,2066+17]..[103,2066+18])
+ ptyext_params =
+ []
+ ptyext_constructors =
+ [
+ extension_constructor (shortcut_ext_attr.ml[103,2066+22]..[103,2066+23])
+ pext_name = "T"
+ pext_kind =
+ Pext_decl
+ []
+ None
+ ]
+ ptyext_private = Public
+ ]
+ signature_item (shortcut_ext_attr.ml[105,2091+2]..[105,2091+23]) ghost
+ Psig_extension "foo"
+ [
+ signature_item (shortcut_ext_attr.ml[105,2091+2]..[105,2091+23])
+ Psig_exception
+ extension_constructor (shortcut_ext_attr.ml[105,2091+2]..[105,2091+23])
+ attribute "foo"
+ []
+ pext_name = "X"
+ pext_kind =
+ Pext_decl
+ []
+ None
+ ]
+ signature_item (shortcut_ext_attr.ml[107,2116+2]..[107,2116+24]) ghost
+ Psig_extension "foo"
+ [
+ signature_item (shortcut_ext_attr.ml[107,2116+2]..[107,2116+24])
+ Psig_module "M" (shortcut_ext_attr.ml[107,2116+19]..[107,2116+20])
+ attribute "foo"
+ []
+ module_type (shortcut_ext_attr.ml[107,2116+23]..[107,2116+24])
+ Pmty_ident "S" (shortcut_ext_attr.ml[107,2116+23]..[107,2116+24])
+ ]
+ signature_item (shortcut_ext_attr.ml[108,2141+2]..[109,2170+17]) ghost
+ Psig_extension "foo"
+ [
+ signature_item (shortcut_ext_attr.ml[108,2141+2]..[109,2170+17])
+ Psig_recmodule
+ [
+ "M" (shortcut_ext_attr.ml[108,2141+23]..[108,2141+24])
+ attribute "foo"
+ []
+ module_type (shortcut_ext_attr.ml[108,2141+27]..[108,2141+28])
+ Pmty_ident "S" (shortcut_ext_attr.ml[108,2141+27]..[108,2141+28])
+ "M" (shortcut_ext_attr.ml[109,2170+12]..[109,2170+13])
+ attribute "foo"
+ []
+ module_type (shortcut_ext_attr.ml[109,2170+16]..[109,2170+17])
+ Pmty_ident "S" (shortcut_ext_attr.ml[109,2170+16]..[109,2170+17])
+ ]
+ ]
+ signature_item (shortcut_ext_attr.ml[110,2188+2]..[110,2188+24]) ghost
+ Psig_extension "foo"
+ [
+ signature_item (shortcut_ext_attr.ml[110,2188+2]..[110,2188+24])
+ Psig_module "M" (shortcut_ext_attr.ml[110,2188+19]..[110,2188+20])
+ attribute "foo"
+ []
+ module_type (shortcut_ext_attr.ml[110,2188+23]..[110,2188+24])
+ Pmty_alias "M" (shortcut_ext_attr.ml[110,2188+23]..[110,2188+24])
+ ]
+ signature_item (shortcut_ext_attr.ml[112,2214+2]..[112,2214+29]) ghost
+ Psig_extension "foo"
+ [
+ signature_item (shortcut_ext_attr.ml[112,2214+2]..[112,2214+29])
+ Psig_modtype "S" (shortcut_ext_attr.ml[112,2214+24]..[112,2214+25])
+ attribute "foo"
+ []
+ module_type (shortcut_ext_attr.ml[112,2214+28]..[112,2214+29])
+ Pmty_ident "S" (shortcut_ext_attr.ml[112,2214+28]..[112,2214+29])
+ ]
+ signature_item (shortcut_ext_attr.ml[114,2245+2]..[114,2245+21]) ghost
+ Psig_extension "foo"
+ [
+ signature_item (shortcut_ext_attr.ml[114,2245+2]..[114,2245+21])
+ Psig_include
+ module_type (shortcut_ext_attr.ml[114,2245+20]..[114,2245+21])
+ Pmty_ident "M" (shortcut_ext_attr.ml[114,2245+20]..[114,2245+21])
+ attribute "foo"
+ []
+ ]
+ signature_item (shortcut_ext_attr.ml[115,2267+2]..[115,2267+18]) ghost
+ Psig_extension "foo"
+ [
+ signature_item (shortcut_ext_attr.ml[115,2267+2]..[115,2267+18])
+ Psig_open Fresh "M" (shortcut_ext_attr.ml[115,2267+17]..[115,2267+18])
+ attribute "foo"
+ []
+ ]
+ signature_item (shortcut_ext_attr.ml[117,2287+2]..[117,2287+23]) ghost
+ Psig_extension "foo"
+ [
+ signature_item (shortcut_ext_attr.ml[117,2287+2]..[117,2287+23])
+ Psig_class
+ [
+ class_description (shortcut_ext_attr.ml[117,2287+2]..[117,2287+23])
+ attribute "foo"
+ []
+ pci_virt = Concrete
+ pci_params =
+ []
+ pci_name = "x" (shortcut_ext_attr.ml[117,2287+18]..[117,2287+19])
+ pci_expr =
+ class_type (shortcut_ext_attr.ml[117,2287+22]..[117,2287+23])
+ Pcty_constr "t" (shortcut_ext_attr.ml[117,2287+22]..[117,2287+23])
+ []
+ ]
+ ]
+ signature_item (shortcut_ext_attr.ml[118,2311+2]..[118,2311+28]) ghost
+ Psig_extension "foo"
+ [
+ signature_item (shortcut_ext_attr.ml[118,2311+2]..[118,2311+28])
+ Psig_class_type
+ [
+ class_type_declaration (shortcut_ext_attr.ml[118,2311+2]..[118,2311+28])
+ attribute "foo"
+ []
+ pci_virt = Concrete
+ pci_params =
+ []
+ pci_name = "x" (shortcut_ext_attr.ml[118,2311+23]..[118,2311+24])
+ pci_expr =
+ class_type (shortcut_ext_attr.ml[118,2311+27]..[118,2311+28])
+ Pcty_constr "x" (shortcut_ext_attr.ml[118,2311+27]..[118,2311+28])
+ []
+ ]
+ ]
+ ]
+]
+
+File "shortcut_ext_attr.ml", line 10, characters 6-9:
+Error: Uninterpreted extension 'foo'.
-
+(* TEST
+ flags = "-dparsetree"
+ ocamlc_byte_exit_status = "2"
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ *** check-ocamlc.byte-output
+*)
(* Expressions *)
let () =
let%foo[@foo] x = 3
+++ /dev/null
-[
- structure_item (shortcut_ext_attr.ml[3,19+0]..[24,570+31])
- Pstr_value Nonrec
- [
- <def>
- pattern (shortcut_ext_attr.ml[3,19+4]..[3,19+6])
- Ppat_construct "()" (shortcut_ext_attr.ml[3,19+4]..[3,19+6])
- None
- expression (shortcut_ext_attr.ml[4,28+2]..[24,570+31]) ghost
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[4,28+2]..[24,570+31])
- Pstr_eval
- expression (shortcut_ext_attr.ml[4,28+2]..[24,570+31])
- Pexp_let Nonrec
- [
- <def>
- attribute "foo"
- []
- pattern (shortcut_ext_attr.ml[4,28+16]..[4,28+17])
- Ppat_var "x" (shortcut_ext_attr.ml[4,28+16]..[4,28+17])
- expression (shortcut_ext_attr.ml[4,28+20]..[4,28+21])
- Pexp_constant PConst_int (3,None)
- <def>
- attribute "foo"
- []
- pattern (shortcut_ext_attr.ml[5,50+12]..[5,50+13])
- Ppat_var "y" (shortcut_ext_attr.ml[5,50+12]..[5,50+13])
- expression (shortcut_ext_attr.ml[5,50+16]..[5,50+17])
- Pexp_constant PConst_int (4,None)
- ]
- expression (shortcut_ext_attr.ml[6,71+2]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[6,71+2]..[6,71+36])
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[6,71+3]..[6,71+35])
- Pstr_eval
- expression (shortcut_ext_attr.ml[6,71+3]..[6,71+35])
- attribute "foo"
- []
- Pexp_letmodule "M" (shortcut_ext_attr.ml[6,71+24]..[6,71+25])
- module_expr (shortcut_ext_attr.ml[6,71+28]..[6,71+29])
- Pmod_ident "M" (shortcut_ext_attr.ml[6,71+28]..[6,71+29])
- expression (shortcut_ext_attr.ml[6,71+33]..[6,71+35])
- Pexp_construct "()" (shortcut_ext_attr.ml[6,71+33]..[6,71+35])
- None
- ]
- expression (shortcut_ext_attr.ml[7,110+2]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[7,110+2]..[7,110+30])
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[7,110+3]..[7,110+29])
- Pstr_eval
- expression (shortcut_ext_attr.ml[7,110+3]..[7,110+29])
- attribute "foo"
- []
- Pexp_open Fresh ""M" (shortcut_ext_attr.ml[7,110+22]..[7,110+23])"
- expression (shortcut_ext_attr.ml[7,110+27]..[7,110+29])
- Pexp_construct "()" (shortcut_ext_attr.ml[7,110+27]..[7,110+29])
- None
- ]
- expression (shortcut_ext_attr.ml[8,143+2]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[8,143+2]..[8,143+25])
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[8,143+3]..[8,143+24])
- Pstr_eval
- expression (shortcut_ext_attr.ml[8,143+3]..[8,143+24])
- attribute "foo"
- []
- Pexp_fun
- Nolabel
- None
- pattern (shortcut_ext_attr.ml[8,143+17]..[8,143+18])
- Ppat_var "x" (shortcut_ext_attr.ml[8,143+17]..[8,143+18])
- expression (shortcut_ext_attr.ml[8,143+22]..[8,143+24])
- Pexp_construct "()" (shortcut_ext_attr.ml[8,143+22]..[8,143+24])
- None
- ]
- expression (shortcut_ext_attr.ml[9,171+2]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[9,171+2]..[9,171+30])
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[9,171+3]..[9,171+29])
- Pstr_eval
- expression (shortcut_ext_attr.ml[9,171+3]..[9,171+29])
- attribute "foo"
- []
- Pexp_function
- [
- <case>
- pattern (shortcut_ext_attr.ml[9,171+22]..[9,171+23])
- Ppat_var "x" (shortcut_ext_attr.ml[9,171+22]..[9,171+23])
- expression (shortcut_ext_attr.ml[9,171+27]..[9,171+29])
- Pexp_construct "()" (shortcut_ext_attr.ml[9,171+27]..[9,171+29])
- None
- ]
- ]
- expression (shortcut_ext_attr.ml[10,204+2]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[10,204+2]..[10,204+33])
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[10,204+3]..[10,204+32])
- Pstr_eval
- expression (shortcut_ext_attr.ml[10,204+3]..[10,204+32])
- attribute "foo"
- []
- Pexp_try
- expression (shortcut_ext_attr.ml[10,204+17]..[10,204+19])
- Pexp_construct "()" (shortcut_ext_attr.ml[10,204+17]..[10,204+19])
- None
- [
- <case>
- pattern (shortcut_ext_attr.ml[10,204+25]..[10,204+26])
- Ppat_any
- expression (shortcut_ext_attr.ml[10,204+30]..[10,204+32])
- Pexp_construct "()" (shortcut_ext_attr.ml[10,204+30]..[10,204+32])
- None
- ]
- ]
- expression (shortcut_ext_attr.ml[11,240+2]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[11,240+2]..[11,240+35])
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[11,240+3]..[11,240+34])
- Pstr_eval
- expression (shortcut_ext_attr.ml[11,240+3]..[11,240+34])
- attribute "foo"
- []
- Pexp_ifthenelse
- expression (shortcut_ext_attr.ml[11,240+16]..[11,240+18])
- Pexp_construct "()" (shortcut_ext_attr.ml[11,240+16]..[11,240+18])
- None
- expression (shortcut_ext_attr.ml[11,240+24]..[11,240+26])
- Pexp_construct "()" (shortcut_ext_attr.ml[11,240+24]..[11,240+26])
- None
- Some
- expression (shortcut_ext_attr.ml[11,240+32]..[11,240+34])
- Pexp_construct "()" (shortcut_ext_attr.ml[11,240+32]..[11,240+34])
- None
- ]
- expression (shortcut_ext_attr.ml[12,278+2]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[12,278+2]..[12,278+31]) ghost
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[12,278+2]..[12,278+31])
- Pstr_eval
- expression (shortcut_ext_attr.ml[12,278+2]..[12,278+31])
- attribute "foo"
- []
- Pexp_while
- expression (shortcut_ext_attr.ml[12,278+18]..[12,278+20])
- Pexp_construct "()" (shortcut_ext_attr.ml[12,278+18]..[12,278+20])
- None
- expression (shortcut_ext_attr.ml[12,278+24]..[12,278+26])
- Pexp_construct "()" (shortcut_ext_attr.ml[12,278+24]..[12,278+26])
- None
- ]
- expression (shortcut_ext_attr.ml[13,312+2]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[13,312+2]..[13,312+39]) ghost
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[13,312+2]..[13,312+39])
- Pstr_eval
- expression (shortcut_ext_attr.ml[13,312+2]..[13,312+39])
- attribute "foo"
- []
- Pexp_for Up
- pattern (shortcut_ext_attr.ml[13,312+16]..[13,312+17])
- Ppat_var "x" (shortcut_ext_attr.ml[13,312+16]..[13,312+17])
- expression (shortcut_ext_attr.ml[13,312+20]..[13,312+22])
- Pexp_construct "()" (shortcut_ext_attr.ml[13,312+20]..[13,312+22])
- None
- expression (shortcut_ext_attr.ml[13,312+26]..[13,312+28])
- Pexp_construct "()" (shortcut_ext_attr.ml[13,312+26]..[13,312+28])
- None
- expression (shortcut_ext_attr.ml[13,312+32]..[13,312+34])
- Pexp_construct "()" (shortcut_ext_attr.ml[13,312+32]..[13,312+34])
- None
- ]
- expression (shortcut_ext_attr.ml[14,354+2]..[24,570+31])
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[14,354+2]..[24,570+31])
- Pstr_eval
- expression (shortcut_ext_attr.ml[14,354+2]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[14,354+2]..[14,354+4])
- Pexp_construct "()" (shortcut_ext_attr.ml[14,354+2]..[14,354+4])
- None
- expression (shortcut_ext_attr.ml[14,354+11]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[14,354+11]..[14,354+13])
- Pexp_construct "()" (shortcut_ext_attr.ml[14,354+11]..[14,354+13])
- None
- expression (shortcut_ext_attr.ml[15,370+2]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[15,370+2]..[15,370+23]) ghost
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[15,370+2]..[15,370+23])
- Pstr_eval
- expression (shortcut_ext_attr.ml[15,370+2]..[15,370+23])
- attribute "foo"
- []
- Pexp_assert
- expression (shortcut_ext_attr.ml[15,370+19]..[15,370+23])
- Pexp_construct "true" (shortcut_ext_attr.ml[15,370+19]..[15,370+23])
- None
- ]
- expression (shortcut_ext_attr.ml[16,396+2]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[16,396+2]..[16,396+18]) ghost
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[16,396+2]..[16,396+18])
- Pstr_eval
- expression (shortcut_ext_attr.ml[16,396+2]..[16,396+18])
- attribute "foo"
- []
- Pexp_lazy
- expression (shortcut_ext_attr.ml[16,396+17]..[16,396+18])
- Pexp_ident "x" (shortcut_ext_attr.ml[16,396+17]..[16,396+18])
- ]
- expression (shortcut_ext_attr.ml[17,417+2]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[17,417+2]..[17,417+22]) ghost
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[17,417+2]..[17,417+22])
- Pstr_eval
- expression (shortcut_ext_attr.ml[17,417+2]..[17,417+22])
- attribute "foo"
- []
- Pexp_object
- class_structure
- pattern (shortcut_ext_attr.ml[17,417+18]..[17,417+18]) ghost
- Ppat_any
- []
- ]
- expression (shortcut_ext_attr.ml[18,442+2]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[18,442+2]..[18,442+23]) ghost
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[18,442+2]..[18,442+23])
- Pstr_eval
- expression (shortcut_ext_attr.ml[18,442+2]..[18,442+23])
- attribute "foo"
- []
- Pexp_constant PConst_int (3,None)
- ]
- expression (shortcut_ext_attr.ml[19,468+2]..[24,570+31])
- Pexp_sequence
- expression (shortcut_ext_attr.ml[19,468+2]..[19,468+17]) ghost
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[19,468+2]..[19,468+17])
- Pstr_eval
- expression (shortcut_ext_attr.ml[19,468+2]..[19,468+17])
- attribute "foo"
- []
- Pexp_new "x" (shortcut_ext_attr.ml[19,468+16]..[19,468+17])
- ]
- expression (shortcut_ext_attr.ml[21,489+2]..[24,570+31]) ghost
- Pexp_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[21,489+2]..[24,570+31])
- Pstr_eval
- expression (shortcut_ext_attr.ml[21,489+2]..[24,570+31])
- attribute "foo"
- []
- Pexp_match
- expression (shortcut_ext_attr.ml[21,489+18]..[21,489+20])
- Pexp_construct "()" (shortcut_ext_attr.ml[21,489+18]..[21,489+20])
- None
- [
- <case>
- pattern (shortcut_ext_attr.ml[23,543+4]..[23,543+20]) ghost
- Ppat_extension "foo"
- pattern (shortcut_ext_attr.ml[23,543+4]..[23,543+20])
- attribute "foo"
- []
- Ppat_lazy
- pattern (shortcut_ext_attr.ml[23,543+19]..[23,543+20])
- Ppat_var "x" (shortcut_ext_attr.ml[23,543+19]..[23,543+20])
- expression (shortcut_ext_attr.ml[23,543+24]..[23,543+26])
- Pexp_construct "()" (shortcut_ext_attr.ml[23,543+24]..[23,543+26])
- None
- <case>
- pattern (shortcut_ext_attr.ml[24,570+4]..[24,570+25]) ghost
- Ppat_extension "foo"
- pattern (shortcut_ext_attr.ml[24,570+4]..[24,570+25])
- attribute "foo"
- []
- Ppat_exception
- pattern (shortcut_ext_attr.ml[24,570+24]..[24,570+25])
- Ppat_var "x" (shortcut_ext_attr.ml[24,570+24]..[24,570+25])
- expression (shortcut_ext_attr.ml[24,570+29]..[24,570+31])
- Pexp_construct "()" (shortcut_ext_attr.ml[24,570+29]..[24,570+31])
- None
- ]
- ]
- ]
- ]
- ]
- structure_item (shortcut_ext_attr.ml[28,628+0]..[40,898+5])
- Pstr_class
- [
- class_declaration (shortcut_ext_attr.ml[28,628+0]..[40,898+5])
- pci_virt = Concrete
- pci_params =
- []
- pci_name = "x" (shortcut_ext_attr.ml[28,628+6]..[28,628+7])
- pci_expr =
- class_expr (shortcut_ext_attr.ml[29,638+12]..[40,898+5])
- attribute "foo"
- []
- Pcl_fun
- Nolabel
- None
- pattern (shortcut_ext_attr.ml[29,638+12]..[29,638+13])
- Ppat_var "x" (shortcut_ext_attr.ml[29,638+12]..[29,638+13])
- class_expr (shortcut_ext_attr.ml[30,655+2]..[40,898+5])
- Pcl_let Nonrec
- [
- <def>
- attribute "foo"
- []
- pattern (shortcut_ext_attr.ml[30,655+12]..[30,655+13])
- Ppat_var "x" (shortcut_ext_attr.ml[30,655+12]..[30,655+13])
- expression (shortcut_ext_attr.ml[30,655+16]..[30,655+17])
- Pexp_constant PConst_int (3,None)
- ]
- class_expr (shortcut_ext_attr.ml[31,676+2]..[40,898+5])
- attribute "foo"
- []
- Pcl_structure
- class_structure
- pattern (shortcut_ext_attr.ml[31,676+14]..[31,676+14]) ghost
- Ppat_any
- [
- class_field (shortcut_ext_attr.ml[32,691+4]..[32,691+19])
- attribute "foo"
- []
- Pcf_inherit Fresh
- class_expr (shortcut_ext_attr.ml[32,691+18]..[32,691+19])
- Pcl_constr "x" (shortcut_ext_attr.ml[32,691+18]..[32,691+19])
- []
- None
- class_field (shortcut_ext_attr.ml[33,711+4]..[33,711+19])
- attribute "foo"
- []
- Pcf_val Immutable
- "x" (shortcut_ext_attr.ml[33,711+14]..[33,711+15])
- Concrete Fresh
- expression (shortcut_ext_attr.ml[33,711+18]..[33,711+19])
- Pexp_constant PConst_int (3,None)
- class_field (shortcut_ext_attr.ml[34,731+4]..[34,731+27])
- attribute "foo"
- []
- Pcf_val Immutable
- "x" (shortcut_ext_attr.ml[34,731+22]..[34,731+23])
- Virtual
- core_type (shortcut_ext_attr.ml[34,731+26]..[34,731+27])
- Ptyp_constr "t" (shortcut_ext_attr.ml[34,731+26]..[34,731+27])
- []
- class_field (shortcut_ext_attr.ml[35,759+4]..[35,759+28])
- attribute "foo"
- []
- Pcf_val Mutable
- "x" (shortcut_ext_attr.ml[35,759+23]..[35,759+24])
- Concrete Override
- expression (shortcut_ext_attr.ml[35,759+27]..[35,759+28])
- Pexp_constant PConst_int (3,None)
- class_field (shortcut_ext_attr.ml[36,788+4]..[36,788+22])
- attribute "foo"
- []
- Pcf_method Public
- "x" (shortcut_ext_attr.ml[36,788+17]..[36,788+18])
- Concrete Fresh
- expression (shortcut_ext_attr.ml[36,788+10]..[36,788+22]) ghost
- Pexp_poly
- expression (shortcut_ext_attr.ml[36,788+21]..[36,788+22])
- Pexp_constant PConst_int (3,None)
- None
- class_field (shortcut_ext_attr.ml[37,811+4]..[37,811+30])
- attribute "foo"
- []
- Pcf_method Public
- "x" (shortcut_ext_attr.ml[37,811+25]..[37,811+26])
- Virtual
- core_type (shortcut_ext_attr.ml[37,811+29]..[37,811+30])
- Ptyp_constr "t" (shortcut_ext_attr.ml[37,811+29]..[37,811+30])
- []
- class_field (shortcut_ext_attr.ml[38,842+4]..[38,842+31])
- attribute "foo"
- []
- Pcf_method Private
- "x" (shortcut_ext_attr.ml[38,842+26]..[38,842+27])
- Concrete Override
- expression (shortcut_ext_attr.ml[38,842+10]..[38,842+31]) ghost
- Pexp_poly
- expression (shortcut_ext_attr.ml[38,842+30]..[38,842+31])
- Pexp_constant PConst_int (3,None)
- None
- class_field (shortcut_ext_attr.ml[39,874+4]..[39,874+23])
- attribute "foo"
- []
- Pcf_initializer
- expression (shortcut_ext_attr.ml[39,874+22]..[39,874+23])
- Pexp_ident "x" (shortcut_ext_attr.ml[39,874+22]..[39,874+23])
- ]
- ]
- structure_item (shortcut_ext_attr.ml[43,934+0]..[51,1114+5])
- Pstr_class_type
- [
- class_type_declaration (shortcut_ext_attr.ml[43,934+0]..[51,1114+5])
- pci_virt = Concrete
- pci_params =
- []
- pci_name = "t" (shortcut_ext_attr.ml[43,934+11]..[43,934+12])
- pci_expr =
- class_type (shortcut_ext_attr.ml[44,949+2]..[51,1114+5])
- attribute "foo"
- []
- Pcty_signature
- class_signature
- core_type (shortcut_ext_attr.ml[44,949+14]..[44,949+14])
- Ptyp_any
- [
- class_type_field (shortcut_ext_attr.ml[45,964+4]..[45,964+19])
- attribute "foo"
- []
- Pctf_inherit
- class_type (shortcut_ext_attr.ml[45,964+18]..[45,964+19])
- Pcty_constr "t" (shortcut_ext_attr.ml[45,964+18]..[45,964+19])
- []
- class_type_field (shortcut_ext_attr.ml[46,984+4]..[46,984+19])
- attribute "foo"
- []
- Pctf_val "x" Immutable Concrete
- core_type (shortcut_ext_attr.ml[46,984+18]..[46,984+19])
- Ptyp_constr "t" (shortcut_ext_attr.ml[46,984+18]..[46,984+19])
- []
- class_type_field (shortcut_ext_attr.ml[47,1004+4]..[47,1004+27])
- attribute "foo"
- []
- Pctf_val "x" Mutable Concrete
- core_type (shortcut_ext_attr.ml[47,1004+26]..[47,1004+27])
- Ptyp_constr "t" (shortcut_ext_attr.ml[47,1004+26]..[47,1004+27])
- []
- class_type_field (shortcut_ext_attr.ml[48,1032+4]..[48,1032+22])
- attribute "foo"
- []
- Pctf_method "x" Public Concrete
- core_type (shortcut_ext_attr.ml[48,1032+21]..[48,1032+22])
- Ptyp_constr "t" (shortcut_ext_attr.ml[48,1032+21]..[48,1032+22])
- []
- class_type_field (shortcut_ext_attr.ml[49,1055+4]..[49,1055+30])
- attribute "foo"
- []
- Pctf_method "x" Private Concrete
- core_type (shortcut_ext_attr.ml[49,1055+29]..[49,1055+30])
- Ptyp_constr "t" (shortcut_ext_attr.ml[49,1055+29]..[49,1055+30])
- []
- class_type_field (shortcut_ext_attr.ml[50,1086+4]..[50,1086+27])
- attribute "foo"
- []
- Pctf_constraint
- core_type (shortcut_ext_attr.ml[50,1086+21]..[50,1086+22])
- Ptyp_constr "t" (shortcut_ext_attr.ml[50,1086+21]..[50,1086+22])
- []
- core_type (shortcut_ext_attr.ml[50,1086+25]..[50,1086+27])
- Ptyp_constr "t'" (shortcut_ext_attr.ml[50,1086+25]..[50,1086+27])
- []
- ]
- ]
- structure_item (shortcut_ext_attr.ml[54,1144+0]..[55,1153+22])
- Pstr_type Rec
- [
- type_declaration "t" (shortcut_ext_attr.ml[54,1144+5]..[54,1144+6]) (shortcut_ext_attr.ml[54,1144+0]..[55,1153+22])
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_abstract
- ptype_private = Public
- ptype_manifest =
- Some
- core_type (shortcut_ext_attr.ml[55,1153+2]..[55,1153+22]) ghost
- Ptyp_extension "foo"
- core_type (shortcut_ext_attr.ml[55,1153+2]..[55,1153+22])
- attribute "foo"
- []
- Ptyp_package "M" (shortcut_ext_attr.ml[55,1153+20]..[55,1153+21])
- []
- ]
- structure_item (shortcut_ext_attr.ml[58,1202+0]..[61,1258+22])
- Pstr_module
- "M" (shortcut_ext_attr.ml[58,1202+7]..[58,1202+8])
- module_expr (shortcut_ext_attr.ml[59,1213+2]..[61,1258+22])
- attribute "foo"
- []
- Pmod_functor "M" (shortcut_ext_attr.ml[59,1213+17]..[59,1213+18])
- module_type (shortcut_ext_attr.ml[59,1213+21]..[59,1213+22])
- Pmty_ident "S" (shortcut_ext_attr.ml[59,1213+21]..[59,1213+22])
- module_expr (shortcut_ext_attr.ml[60,1240+4]..[61,1258+22])
- Pmod_apply
- module_expr (shortcut_ext_attr.ml[60,1240+4]..[60,1240+17])
- attribute "foo"
- []
- Pmod_unpack
- expression (shortcut_ext_attr.ml[60,1240+15]..[60,1240+16])
- Pexp_ident "x" (shortcut_ext_attr.ml[60,1240+15]..[60,1240+16])
- module_expr (shortcut_ext_attr.ml[61,1258+5]..[61,1258+21])
- attribute "foo"
- []
- Pmod_structure
- []
- structure_item (shortcut_ext_attr.ml[64,1311+0]..[67,1384+19])
- Pstr_modtype "S" (shortcut_ext_attr.ml[64,1311+12]..[64,1311+13])
- module_type (shortcut_ext_attr.ml[65,1327+2]..[67,1384+19])
- attribute "foo"
- []
- Pmty_functor "M" (shortcut_ext_attr.ml[65,1327+17]..[65,1327+18])
- module_type (shortcut_ext_attr.ml[65,1327+19]..[65,1327+20])
- Pmty_ident "S" (shortcut_ext_attr.ml[65,1327+19]..[65,1327+20])
- module_type (shortcut_ext_attr.ml[66,1352+4]..[67,1384+19])
- Pmty_functor "_" (_none_[1,0+-1]..[1,0+-1]) ghost
- module_type (shortcut_ext_attr.ml[66,1352+5]..[66,1352+27])
- attribute "foo"
- []
- Pmty_typeof
- module_expr (shortcut_ext_attr.ml[66,1352+26]..[66,1352+27])
- Pmod_ident "M" (shortcut_ext_attr.ml[66,1352+26]..[66,1352+27])
- module_type (shortcut_ext_attr.ml[67,1384+5]..[67,1384+18])
- attribute "foo"
- []
- Pmty_signature
- []
- structure_item (shortcut_ext_attr.ml[70,1427+0]..[71,1447+15]) ghost
- Pstr_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[70,1427+0]..[71,1447+15])
- Pstr_value Nonrec
- [
- <def>
- attribute "foo"
- []
- pattern (shortcut_ext_attr.ml[70,1427+14]..[70,1427+15])
- Ppat_var "x" (shortcut_ext_attr.ml[70,1427+14]..[70,1427+15])
- expression (shortcut_ext_attr.ml[70,1427+18]..[70,1427+19])
- Pexp_constant PConst_int (4,None)
- <def>
- attribute "foo"
- []
- pattern (shortcut_ext_attr.ml[71,1447+10]..[71,1447+11])
- Ppat_var "y" (shortcut_ext_attr.ml[71,1447+10]..[71,1447+11])
- expression (shortcut_ext_attr.ml[71,1447+14]..[71,1447+15])
- Pexp_ident "x" (shortcut_ext_attr.ml[71,1447+14]..[71,1447+15])
- ]
- ]
- structure_item (shortcut_ext_attr.ml[73,1464+0]..[74,1487+17]) ghost
- Pstr_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[73,1464+0]..[74,1487+17])
- Pstr_type Rec
- [
- type_declaration "t" (shortcut_ext_attr.ml[73,1464+15]..[73,1464+16]) (shortcut_ext_attr.ml[73,1464+0]..[73,1464+22])
- attribute "foo"
- []
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_abstract
- ptype_private = Public
- ptype_manifest =
- Some
- core_type (shortcut_ext_attr.ml[73,1464+19]..[73,1464+22])
- Ptyp_constr "int" (shortcut_ext_attr.ml[73,1464+19]..[73,1464+22])
- []
- type_declaration "t" (shortcut_ext_attr.ml[74,1487+10]..[74,1487+11]) (shortcut_ext_attr.ml[74,1487+0]..[74,1487+17])
- attribute "foo"
- []
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_abstract
- ptype_private = Public
- ptype_manifest =
- Some
- core_type (shortcut_ext_attr.ml[74,1487+14]..[74,1487+17])
- Ptyp_constr "int" (shortcut_ext_attr.ml[74,1487+14]..[74,1487+17])
- []
- ]
- ]
- structure_item (shortcut_ext_attr.ml[75,1505+0]..[75,1505+21]) ghost
- Pstr_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[75,1505+0]..[75,1505+21])
- Pstr_typext
- type_extension
- attribute "foo"
- []
- ptyext_path = "t" (shortcut_ext_attr.ml[75,1505+15]..[75,1505+16])
- ptyext_params =
- []
- ptyext_constructors =
- [
- extension_constructor (shortcut_ext_attr.ml[75,1505+20]..[75,1505+21])
- pext_name = "T"
- pext_kind =
- Pext_decl
- []
- None
- ]
- ptyext_private = Public
- ]
- structure_item (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21]) ghost
- Pstr_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21])
- Pstr_class
- [
- class_declaration (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21])
- attribute "foo"
- []
- pci_virt = Concrete
- pci_params =
- []
- pci_name = "x" (shortcut_ext_attr.ml[77,1528+16]..[77,1528+17])
- pci_expr =
- class_expr (shortcut_ext_attr.ml[77,1528+20]..[77,1528+21])
- Pcl_constr "x" (shortcut_ext_attr.ml[77,1528+20]..[77,1528+21])
- []
- ]
- ]
- structure_item (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26]) ghost
- Pstr_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26])
- Pstr_class_type
- [
- class_type_declaration (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26])
- attribute "foo"
- []
- pci_virt = Concrete
- pci_params =
- []
- pci_name = "x" (shortcut_ext_attr.ml[78,1550+21]..[78,1550+22])
- pci_expr =
- class_type (shortcut_ext_attr.ml[78,1550+25]..[78,1550+26])
- Pcty_constr "x" (shortcut_ext_attr.ml[78,1550+25]..[78,1550+26])
- []
- ]
- ]
- structure_item (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30]) ghost
- Pstr_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30])
- Pstr_primitive
- value_description "x" (shortcut_ext_attr.ml[79,1577+19]..[79,1577+20]) (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30])
- attribute "foo"
- []
- core_type (shortcut_ext_attr.ml[79,1577+23]..[79,1577+24])
- Ptyp_any
- [
- ""
- ]
- ]
- structure_item (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21]) ghost
- Pstr_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21])
- Pstr_exception
- extension_constructor (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21])
- attribute "foo"
- []
- pext_name = "X"
- pext_kind =
- Pext_decl
- []
- None
- ]
- structure_item (shortcut_ext_attr.ml[82,1631+0]..[82,1631+22]) ghost
- Pstr_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[82,1631+0]..[82,1631+22])
- Pstr_module
- "M" (shortcut_ext_attr.ml[82,1631+17]..[82,1631+18])
- attribute "foo"
- []
- module_expr (shortcut_ext_attr.ml[82,1631+21]..[82,1631+22])
- Pmod_ident "M" (shortcut_ext_attr.ml[82,1631+21]..[82,1631+22])
- ]
- structure_item (shortcut_ext_attr.ml[83,1654+0]..[84,1685+19]) ghost
- Pstr_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[83,1654+0]..[84,1685+19])
- Pstr_recmodule
- [
- "M" (shortcut_ext_attr.ml[83,1654+21]..[83,1654+22])
- attribute "foo"
- []
- module_expr (shortcut_ext_attr.ml[83,1654+23]..[83,1654+30])
- Pmod_constraint
- module_expr (shortcut_ext_attr.ml[83,1654+29]..[83,1654+30])
- Pmod_ident "M" (shortcut_ext_attr.ml[83,1654+29]..[83,1654+30])
- module_type (shortcut_ext_attr.ml[83,1654+25]..[83,1654+26])
- Pmty_ident "S" (shortcut_ext_attr.ml[83,1654+25]..[83,1654+26])
- "M" (shortcut_ext_attr.ml[84,1685+10]..[84,1685+11])
- attribute "foo"
- []
- module_expr (shortcut_ext_attr.ml[84,1685+12]..[84,1685+19])
- Pmod_constraint
- module_expr (shortcut_ext_attr.ml[84,1685+18]..[84,1685+19])
- Pmod_ident "M" (shortcut_ext_attr.ml[84,1685+18]..[84,1685+19])
- module_type (shortcut_ext_attr.ml[84,1685+14]..[84,1685+15])
- Pmty_ident "S" (shortcut_ext_attr.ml[84,1685+14]..[84,1685+15])
- ]
- ]
- structure_item (shortcut_ext_attr.ml[85,1705+0]..[85,1705+27]) ghost
- Pstr_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[85,1705+0]..[85,1705+27])
- Pstr_modtype "S" (shortcut_ext_attr.ml[85,1705+22]..[85,1705+23])
- attribute "foo"
- []
- module_type (shortcut_ext_attr.ml[85,1705+26]..[85,1705+27])
- Pmty_ident "S" (shortcut_ext_attr.ml[85,1705+26]..[85,1705+27])
- ]
- structure_item (shortcut_ext_attr.ml[87,1734+0]..[87,1734+19]) ghost
- Pstr_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[87,1734+0]..[87,1734+19])
- Pstr_include attribute "foo"
- []
- module_expr (shortcut_ext_attr.ml[87,1734+18]..[87,1734+19])
- Pmod_ident "M" (shortcut_ext_attr.ml[87,1734+18]..[87,1734+19])
- ]
- structure_item (shortcut_ext_attr.ml[88,1754+0]..[88,1754+16]) ghost
- Pstr_extension "foo"
- [
- structure_item (shortcut_ext_attr.ml[88,1754+0]..[88,1754+16])
- Pstr_open Fresh "M" (shortcut_ext_attr.ml[88,1754+15]..[88,1754+16])
- attribute "foo"
- []
- ]
- structure_item (shortcut_ext_attr.ml[91,1794+0]..[114,2190+3])
- Pstr_modtype "S" (shortcut_ext_attr.ml[91,1794+12]..[91,1794+13])
- module_type (shortcut_ext_attr.ml[91,1794+16]..[114,2190+3])
- Pmty_signature
- [
- signature_item (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21]) ghost
- Psig_extension "foo"
- [
- signature_item (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21])
- Psig_value
- value_description "x" (shortcut_ext_attr.ml[92,1814+16]..[92,1814+17]) (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21])
- attribute "foo"
- []
- core_type (shortcut_ext_attr.ml[92,1814+20]..[92,1814+21])
- Ptyp_constr "t" (shortcut_ext_attr.ml[92,1814+20]..[92,1814+21])
- []
- []
- ]
- signature_item (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31]) ghost
- Psig_extension "foo"
- [
- signature_item (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31])
- Psig_value
- value_description "x" (shortcut_ext_attr.ml[93,1836+21]..[93,1836+22]) (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31])
- attribute "foo"
- []
- core_type (shortcut_ext_attr.ml[93,1836+25]..[93,1836+26])
- Ptyp_constr "t" (shortcut_ext_attr.ml[93,1836+25]..[93,1836+26])
- []
- [
- ""
- ]
- ]
- signature_item (shortcut_ext_attr.ml[95,1869+2]..[96,1894+20]) ghost
- Psig_extension "foo"
- [
- signature_item (shortcut_ext_attr.ml[95,1869+2]..[96,1894+20])
- Psig_type Rec
- [
- type_declaration "t" (shortcut_ext_attr.ml[95,1869+17]..[95,1869+18]) (shortcut_ext_attr.ml[95,1869+2]..[95,1869+24])
- attribute "foo"
- []
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_abstract
- ptype_private = Public
- ptype_manifest =
- Some
- core_type (shortcut_ext_attr.ml[95,1869+21]..[95,1869+24])
- Ptyp_constr "int" (shortcut_ext_attr.ml[95,1869+21]..[95,1869+24])
- []
- type_declaration "t'" (shortcut_ext_attr.ml[96,1894+12]..[96,1894+14]) (shortcut_ext_attr.ml[96,1894+2]..[96,1894+20])
- attribute "foo"
- []
- ptype_params =
- []
- ptype_cstrs =
- []
- ptype_kind =
- Ptype_abstract
- ptype_private = Public
- ptype_manifest =
- Some
- core_type (shortcut_ext_attr.ml[96,1894+17]..[96,1894+20])
- Ptyp_constr "int" (shortcut_ext_attr.ml[96,1894+17]..[96,1894+20])
- []
- ]
- ]
- signature_item (shortcut_ext_attr.ml[97,1915+2]..[97,1915+23]) ghost
- Psig_extension "foo"
- [
- signature_item (shortcut_ext_attr.ml[97,1915+2]..[97,1915+23])
- Psig_typext
- type_extension
- attribute "foo"
- []
- ptyext_path = "t" (shortcut_ext_attr.ml[97,1915+17]..[97,1915+18])
- ptyext_params =
- []
- ptyext_constructors =
- [
- extension_constructor (shortcut_ext_attr.ml[97,1915+22]..[97,1915+23])
- pext_name = "T"
- pext_kind =
- Pext_decl
- []
- None
- ]
- ptyext_private = Public
- ]
- signature_item (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23]) ghost
- Psig_extension "foo"
- [
- signature_item (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23])
- Psig_exception
- extension_constructor (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23])
- attribute "foo"
- []
- pext_name = "X"
- pext_kind =
- Pext_decl
- []
- None
- ]
- signature_item (shortcut_ext_attr.ml[101,1965+2]..[101,1965+24]) ghost
- Psig_extension "foo"
- [
- signature_item (shortcut_ext_attr.ml[101,1965+2]..[101,1965+24])
- Psig_module "M" (shortcut_ext_attr.ml[101,1965+19]..[101,1965+20])
- attribute "foo"
- []
- module_type (shortcut_ext_attr.ml[101,1965+23]..[101,1965+24])
- Pmty_ident "S" (shortcut_ext_attr.ml[101,1965+23]..[101,1965+24])
- ]
- signature_item (shortcut_ext_attr.ml[102,1990+2]..[103,2019+17]) ghost
- Psig_extension "foo"
- [
- signature_item (shortcut_ext_attr.ml[102,1990+2]..[103,2019+17])
- Psig_recmodule
- [
- "M" (shortcut_ext_attr.ml[102,1990+23]..[102,1990+24])
- attribute "foo"
- []
- module_type (shortcut_ext_attr.ml[102,1990+27]..[102,1990+28])
- Pmty_ident "S" (shortcut_ext_attr.ml[102,1990+27]..[102,1990+28])
- "M" (shortcut_ext_attr.ml[103,2019+12]..[103,2019+13])
- attribute "foo"
- []
- module_type (shortcut_ext_attr.ml[103,2019+16]..[103,2019+17])
- Pmty_ident "S" (shortcut_ext_attr.ml[103,2019+16]..[103,2019+17])
- ]
- ]
- signature_item (shortcut_ext_attr.ml[104,2037+2]..[104,2037+24]) ghost
- Psig_extension "foo"
- [
- signature_item (shortcut_ext_attr.ml[104,2037+2]..[104,2037+24])
- Psig_module "M" (shortcut_ext_attr.ml[104,2037+19]..[104,2037+20])
- attribute "foo"
- []
- module_type (shortcut_ext_attr.ml[104,2037+23]..[104,2037+24])
- Pmty_alias "M" (shortcut_ext_attr.ml[104,2037+23]..[104,2037+24])
- ]
- signature_item (shortcut_ext_attr.ml[106,2063+2]..[106,2063+29]) ghost
- Psig_extension "foo"
- [
- signature_item (shortcut_ext_attr.ml[106,2063+2]..[106,2063+29])
- Psig_modtype "S" (shortcut_ext_attr.ml[106,2063+24]..[106,2063+25])
- attribute "foo"
- []
- module_type (shortcut_ext_attr.ml[106,2063+28]..[106,2063+29])
- Pmty_ident "S" (shortcut_ext_attr.ml[106,2063+28]..[106,2063+29])
- ]
- signature_item (shortcut_ext_attr.ml[108,2094+2]..[108,2094+21]) ghost
- Psig_extension "foo"
- [
- signature_item (shortcut_ext_attr.ml[108,2094+2]..[108,2094+21])
- Psig_include
- module_type (shortcut_ext_attr.ml[108,2094+20]..[108,2094+21])
- Pmty_ident "M" (shortcut_ext_attr.ml[108,2094+20]..[108,2094+21])
- attribute "foo"
- []
- ]
- signature_item (shortcut_ext_attr.ml[109,2116+2]..[109,2116+18]) ghost
- Psig_extension "foo"
- [
- signature_item (shortcut_ext_attr.ml[109,2116+2]..[109,2116+18])
- Psig_open Fresh "M" (shortcut_ext_attr.ml[109,2116+17]..[109,2116+18])
- attribute "foo"
- []
- ]
- signature_item (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23]) ghost
- Psig_extension "foo"
- [
- signature_item (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23])
- Psig_class
- [
- class_description (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23])
- attribute "foo"
- []
- pci_virt = Concrete
- pci_params =
- []
- pci_name = "x" (shortcut_ext_attr.ml[111,2136+18]..[111,2136+19])
- pci_expr =
- class_type (shortcut_ext_attr.ml[111,2136+22]..[111,2136+23])
- Pcty_constr "t" (shortcut_ext_attr.ml[111,2136+22]..[111,2136+23])
- []
- ]
- ]
- signature_item (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28]) ghost
- Psig_extension "foo"
- [
- signature_item (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28])
- Psig_class_type
- [
- class_type_declaration (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28])
- attribute "foo"
- []
- pci_virt = Concrete
- pci_params =
- []
- pci_name = "x" (shortcut_ext_attr.ml[112,2160+23]..[112,2160+24])
- pci_expr =
- class_type (shortcut_ext_attr.ml[112,2160+27]..[112,2160+28])
- Pcty_constr "x" (shortcut_ext_attr.ml[112,2160+27]..[112,2160+28])
- []
- ]
- ]
- ]
-]
-
-File "shortcut_ext_attr.ml", line 4, characters 6-9:
-Error: Uninterpreted extension 'foo'.
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Peter Zotov *
-#* *
-#* Copyright 2014 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+warning.ml
+(* TEST
+*)
+
[@@@ocaml.warning "@A"]
(* Fixture *)
+++ /dev/null
-BASEDIR=../..
-
-INCLUDES=\
- -I $(OTOPDIR)/parsing \
- -I $(OTOPDIR)/utils \
- -I $(OTOPDIR)/compilerlibs
-
-myppx=$(shell $(CYGPATH) '$(OCAMLRUN)') ./program$(EXE)
-
-.PHONY: run
-run: program$(EXE) test.reference
- @echo " ... testing -thread and -vmthread are propagated to PPX:"
- @( $(OCAMLC) -c -thread -ppx '$(myppx)' test.ml \
- && $(OCAMLC) -c -vmthread -ppx '$(myppx)' test.ml ) 2> test.result
- @$(DIFF) test.reference test.result >/dev/null \
- && echo " => passed" || echo " => failed"
-
-program$(EXE): program.ml Makefile
- @$(OCAMLC) -o program$(EXE) $(INCLUDES) ocamlcommon.cma ./program.ml
-
-.PHONY: promote
-promote: defaultpromote
-
-.PHONY: clean
-clean: defaultclean
- @rm -f program$(EXE) test.result *.cm*
-
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+(* A simple PPX *)
+
+open Ast_mapper
+
+let () =
+ register "test" (fun _ ->
+ Printf.eprintf "use_threads=%b\n" !Clflags.use_threads;
+ Printf.eprintf "use_vmthreads=%b\n" !Clflags.use_vmthreads;
+ default_mapper);
+
+++ /dev/null
-(* A simple PPX *)
-
-open Ast_mapper
-
-let () =
- register "test" (fun _ ->
- Printf.eprintf "use_threads=%b\n" !Clflags.use_threads;
- Printf.eprintf "use_vmthreads=%b\n" !Clflags.use_vmthreads;
- default_mapper);
-
--- /dev/null
+use_threads=true
+use_vmthreads=false
+use_threads=false
+use_vmthreads=true
+(* TEST
+files = "myppx.ml"
+include ocamlcommon
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+program = "${test_build_directory}/myppx.exe"
+all_modules = "myppx.ml"
+*** ocamlc.byte
+module = "test.ml"
+flags = "-thread -ppx ${program}"
+**** ocamlc.byte
+module = "test.ml"
+flags = "-vmthread -ppx ${program}"
+***** check-ocamlc.byte-output
+*)
+
(* empty *)
+++ /dev/null
-use_threads=true
-use_vmthreads=false
-use_threads=false
-use_vmthreads=true
+++ /dev/null
-BASEDIR=../..
-LIBRARIES=unix bigarray
-ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
- -I $(OTOPDIR)/otherlibs/bigarray
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/bigarray
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
open Bigarray
type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t
--- /dev/null
+bigstring_access.ml
+string_access.ml
+(* TEST
+*)
-external caml_string_get_16 : string -> int -> int = "%caml_string_get16"
-external caml_string_get_32 : string -> int -> int32 = "%caml_string_get32"
-external caml_string_get_64 : string -> int -> int64 = "%caml_string_get64"
+external caml_bytes_get_16 : bytes -> int -> int = "%caml_bytes_get16"
+external caml_bytes_get_32 : bytes -> int -> int32 = "%caml_bytes_get32"
+external caml_bytes_get_64 : bytes -> int -> int64 = "%caml_bytes_get64"
-external caml_string_set_16 : string -> int -> int -> unit =
- "%caml_string_set16"
-external caml_string_set_32 : string -> int -> int32 -> unit =
- "%caml_string_set32"
-external caml_string_set_64 : string -> int -> int64 -> unit =
- "%caml_string_set64"
+external caml_bytes_set_16 : bytes -> int -> int -> unit =
+ "%caml_bytes_set16"
+external caml_bytes_set_32 : bytes -> int -> int32 -> unit =
+ "%caml_bytes_set32"
+external caml_bytes_set_64 : bytes -> int -> int64 -> unit =
+ "%caml_bytes_set64"
-let s = String.make 10 '\x00'
-let empty_s = ""
+let s = Bytes.make 10 '\x00'
+let empty_s = Bytes.create 0
let assert_bound_check2 f v1 v2 =
try
| Invalid_argument _ -> ()
let () =
- assert_bound_check2 caml_string_get_16 s (-1);
- assert_bound_check2 caml_string_get_16 s 9;
- assert_bound_check2 caml_string_get_32 s (-1);
- assert_bound_check2 caml_string_get_32 s 7;
- assert_bound_check2 caml_string_get_64 s (-1);
- assert_bound_check2 caml_string_get_64 s 3;
-
- assert_bound_check3 caml_string_set_16 s (-1) 0;
- assert_bound_check3 caml_string_set_16 s 9 0;
- assert_bound_check3 caml_string_set_32 s (-1) 0l;
- assert_bound_check3 caml_string_set_32 s 7 0l;
- assert_bound_check3 caml_string_set_64 s (-1) 0L;
- assert_bound_check3 caml_string_set_64 s 3 0L;
-
- assert_bound_check2 caml_string_get_16 empty_s 0;
- assert_bound_check2 caml_string_get_32 empty_s 0;
- assert_bound_check2 caml_string_get_64 empty_s 0;
-
- assert_bound_check3 caml_string_set_16 empty_s 0 0;
- assert_bound_check3 caml_string_set_32 empty_s 0 0l;
- assert_bound_check3 caml_string_set_64 empty_s 0 0L
+ assert_bound_check2 caml_bytes_get_16 s (-1);
+ assert_bound_check2 caml_bytes_get_16 s 9;
+ assert_bound_check2 caml_bytes_get_32 s (-1);
+ assert_bound_check2 caml_bytes_get_32 s 7;
+ assert_bound_check2 caml_bytes_get_64 s (-1);
+ assert_bound_check2 caml_bytes_get_64 s 3;
+
+ assert_bound_check3 caml_bytes_set_16 s (-1) 0;
+ assert_bound_check3 caml_bytes_set_16 s 9 0;
+ assert_bound_check3 caml_bytes_set_32 s (-1) 0l;
+ assert_bound_check3 caml_bytes_set_32 s 7 0l;
+ assert_bound_check3 caml_bytes_set_64 s (-1) 0L;
+ assert_bound_check3 caml_bytes_set_64 s 3 0L;
+
+ assert_bound_check2 caml_bytes_get_16 empty_s 0;
+ assert_bound_check2 caml_bytes_get_32 empty_s 0;
+ assert_bound_check2 caml_bytes_get_64 empty_s 0;
+
+ assert_bound_check3 caml_bytes_set_16 empty_s 0 0;
+ assert_bound_check3 caml_bytes_set_32 empty_s 0 0l;
+ assert_bound_check3 caml_bytes_set_64 empty_s 0 0L
external bswap16: int -> int = "%bswap16"
external bswap32: int32 -> int32 = "%bswap_int32"
else x
let () =
- caml_string_set_16 s 0 (swap16 0x1234);
+ caml_bytes_set_16 s 0 (swap16 0x1234);
Printf.printf "%x %x %x\n%!"
- (swap16 (caml_string_get_16 s 0))
- (swap16 (caml_string_get_16 s 1))
- (swap16 (caml_string_get_16 s 2));
- caml_string_set_16 s 0 (swap16 0xFEDC);
+ (swap16 (caml_bytes_get_16 s 0))
+ (swap16 (caml_bytes_get_16 s 1))
+ (swap16 (caml_bytes_get_16 s 2));
+ caml_bytes_set_16 s 0 (swap16 0xFEDC);
Printf.printf "%x %x %x\n%!"
- (swap16 (caml_string_get_16 s 0))
- (swap16 (caml_string_get_16 s 1))
- (swap16 (caml_string_get_16 s 2))
+ (swap16 (caml_bytes_get_16 s 0))
+ (swap16 (caml_bytes_get_16 s 1))
+ (swap16 (caml_bytes_get_16 s 2))
let () =
- caml_string_set_32 s 0 (swap32 0x12345678l);
+ caml_bytes_set_32 s 0 (swap32 0x12345678l);
Printf.printf "%lx %lx %lx\n%!"
- (swap32 (caml_string_get_32 s 0))
- (swap32 (caml_string_get_32 s 1))
- (swap32 (caml_string_get_32 s 2));
- caml_string_set_32 s 0 (swap32 0xFEDCBA09l);
+ (swap32 (caml_bytes_get_32 s 0))
+ (swap32 (caml_bytes_get_32 s 1))
+ (swap32 (caml_bytes_get_32 s 2));
+ caml_bytes_set_32 s 0 (swap32 0xFEDCBA09l);
Printf.printf "%lx %lx %lx\n%!"
- (swap32 (caml_string_get_32 s 0))
- (swap32 (caml_string_get_32 s 1))
- (swap32 (caml_string_get_32 s 2))
+ (swap32 (caml_bytes_get_32 s 0))
+ (swap32 (caml_bytes_get_32 s 1))
+ (swap32 (caml_bytes_get_32 s 2))
let () =
- caml_string_set_64 s 0 (swap64 0x1234567890ABCDEFL);
+ caml_bytes_set_64 s 0 (swap64 0x1234567890ABCDEFL);
Printf.printf "%Lx %Lx %Lx\n%!"
- (swap64 (caml_string_get_64 s 0))
- (swap64 (caml_string_get_64 s 1))
- (swap64 (caml_string_get_64 s 2));
- caml_string_set_64 s 0 (swap64 0xFEDCBA0987654321L);
+ (swap64 (caml_bytes_get_64 s 0))
+ (swap64 (caml_bytes_get_64 s 1))
+ (swap64 (caml_bytes_get_64 s 2));
+ caml_bytes_set_64 s 0 (swap64 0xFEDCBA0987654321L);
Printf.printf "%Lx %Lx %Lx\n%!"
- (swap64 (caml_string_get_64 s 0))
- (swap64 (caml_string_get_64 s 1))
- (swap64 (caml_string_get_64 s 2))
+ (swap64 (caml_bytes_get_64 s 0))
+ (swap64 (caml_bytes_get_64 s 1))
+ (swap64 (caml_bytes_get_64 s 2))
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Benedikt Meurer, os-cillation GmbH #
-# #
-# Copyright 1998 Institut National de Recherche en Informatique #
-# et en Automatique. Copyright 2013 Benedikt Meurer. All rights #
-# reserved. This file is distributed under the terms of the Q #
-# Public License version 1.0. #
-# #
-#########################################################################
-
-BASEDIR=../..
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
open Printf
external bswap16: int -> int = "%bswap16"
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+*)
+
external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
let f x = x + x
--- /dev/null
+apply.ml
+revapply.ml
+(* TEST
+*)
+
external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
let f x = x + x
+++ /dev/null
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * toplevel
+*)
+
(** Test that weak variables keep their names long enough *)
let f y = fun x -> x
+++ /dev/null
-
-# val f : 'a -> 'b -> 'b = <fun>
-val blah : '_weak1 -> '_weak1 = <fun>
-val splash : unit -> '_weak1 = <fun>
-val blurp : '_weak2 -> '_weak2 = <fun>
-# - : int = 1
-# val g : '_weak3 -> '_weak3 = <fun>
-# - : '_weak4 -> '_weak4 = <fun>
-# val h : '_weak4 -> '_weak4 = <fun>
-#
--- /dev/null
+val f : 'a -> 'b -> 'b = <fun>
+val blah : '_weak1 -> '_weak1 = <fun>
+val splash : unit -> '_weak1 = <fun>
+val blurp : '_weak2 -> '_weak2 = <fun>
+- : int = 1
+val g : '_weak3 -> '_weak3 = <fun>
+- : '_weak4 -> '_weak4 = <fun>
+val h : '_weak4 -> '_weak4 = <fun>
+
--- /dev/null
+(* TEST
+ arguments = "???"
+ *)
+
+(* On Windows the runtime expand windows wildcards (asterisks and
+ * question marks).
+ *
+ * This file is a non-regression test for github's PR#1623.
+ *
+ * On Windows 64bits, a segfault was triggered when one argument consists
+ * only of wildcards.
+ *
+ * The source code of this test is empty: we just check the arguments
+ * expansion.
+ * *)
--- /dev/null
+gpr1623.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-
-.PHONY: default
-default:
- @if $(BYTECODE_ONLY); then $(MAKE) skip ; else \
- $(MAKE) compile; \
- fi
-
-.PHONY: skip
-skip:
- @echo " ... testing 'missing_set_of_closures' => skipped"
-
-.PHONY: compile
-compile:
- @$(OCAMLOPT) -c a.ml
- @$(OCAMLOPT) -c b.ml
- @$(OCAMLOPT) -c b2.ml
- @cp b.cmx b.cmi b2.cmx b2.cmi dir/
- @cd dir; printf " ... testing 'missing_set_of_closures'"; \
- $(OCAMLOPT) -w -58 -c c.ml \
- && echo " => passed" || echo " => failed"; \
-
-.PHONY: promote
-promote:
-
-.PHONY: clean
-clean: defaultclean
- @rm -f *.cmi *.cmx *.$(O) dir/*.cmi dir/*.cmx dir/*.$(O)
-
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+(* TEST
+files = "a.ml b.ml b2.ml"
+* setup-ocamlopt.byte-build-env
+** script
+script = "mkdir -p dir"
+*** script
+script = "cp ${test_source_directory}/dir/c.ml dir/"
+**** ocamlopt.byte
+module = "a.ml"
+***** ocamlopt.byte
+module = "b.ml"
+****** ocamlopt.byte
+module = "b2.ml"
+******* script
+script = "cp b.cmx b.cmi b2.cmx b2.cmi dir/"
+******** cd
+cwd = "dir"
+********* ocamlopt.byte
+module = "c.ml"
+flags = "-w -58"
+********** check-ocamlopt.byte-output
+*)
--- /dev/null
+missing_set_of_closures.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Pierre Chambart, OCamlPro *
-#* *
-#* Copyright 2014 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-MAIN_MODULE=pr3612
-C_FILES=custom_finalize
-
-BASEDIR=../../..
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ modules = "custom_finalize.c"
+*)
+
type t
external test_alloc : unit -> t = "caml_test_pr3612_alloc"
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-ADD_COMPFLAGS = -pp 'camlp4o pa_macro.cmo'
-MAIN_MODULE = pr5080_notes_ok
-
-include ../../../makefiles/Makefile.okbad
-include ../../../makefiles/Makefile.common
+++ /dev/null
-let marshal_int f =
- match [] with
- | _ :: `INT n :: _ -> f n
- | _ -> failwith "marshal_int"
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-MAIN_MODULE=pr5233
-
-include ../../../makefiles/Makefile.one
-include ../../../makefiles/Makefile.common
+(* TEST *)
+
open Printf;;
(* PR#5233: Create a dangling pointer and use it to access random parts
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-MAIN_MODULE=pr5757
-
-include ../../../makefiles/Makefile.one
-include ../../../makefiles/Makefile.common
+(* TEST *)
+
Random.init 3;;
for i = 0 to 100_000 do
ignore (Bytes.create (Random.int 1_000_000))
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Damien Doligez, projet Gallium, INRIA Rocquencourt *
-#* *
-#* Copyright 2013 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-MAIN_MODULE=pr6024
-
-BASEDIR=../../..
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST *)
+
Format.printf "@[%@-@@-@]@.";;
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Damien Doligez, projet Gallium, INRIA Rocquencourt *
-#* *
-#* Copyright 2013 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-MAIN_MODULE=pr7042
-
-BASEDIR=../../..
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST *)
+
let _ =
let a = [| 0.0; -. 0.0 |] in
Printf.printf "%Lx %Lx\n"
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Damien Doligez, projet Gallium, INRIA Rocquencourt *
-#* *
-#* Copyright 2013 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-MAIN_MODULE=pr7426
-
-BASEDIR=../../..
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST *)
+
class some_class = object val some_val = 0.0 end
+++ /dev/null
-# Ensure that calling an external C primite forces linking
-# the module that defines it
-
-MAIN_MODULE = main
-LIBRARIES = lib
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
-
-main.cmo: lib.cma
-main.cmx: lib.cmxa
-
-lib.cma: file.cmo
- @$(OCAMLC) -a -o $@ $<
-
-lib.cmxa: file.cmx
- @$(OCAMLOPT) -a -o $@ $<
+(* TEST
+modules = "file.ml"
+
+* setup-ocamlc.byte-build-env
+program = "${test_build_directory}/main.exe"
+** ocamlc.byte
+module = "file.ml"
+*** ocamlc.byte
+module = ""
+program = "lib.cma"
+flags = "-a"
+all_modules = "file.cmo"
+**** ocamlc.byte
+program = "${test_build_directory}/main.exe"
+all_modules = "lib.cma main.ml"
+flags = ""
+***** check-ocamlc.byte-output
+****** run
+******* check-program-output
+
+* setup-ocamlopt.byte-build-env
+program = "${test_build_directory}/main.exe"
+** ocamlopt.byte
+module = "file.ml"
+*** ocamlopt.byte
+module = ""
+program = "lib.cmxa"
+flags = "-a"
+all_modules = "file.cmx"
+**** ocamlopt.byte
+program = "${test_build_directory}/main.exe"
+all_modules = "lib.cmxa main.ml"
+flags = ""
+***** check-ocamlopt.byte-output
+****** run
+******* check-program-output
+
+*)
+
let () =
ignore (File.getcwd ())
+++ /dev/null
-BASEDIR=../..
-#MODULES=
-MAIN_MODULE=test
-C_FILES=stub_test
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ modules = "stub_test.c"
+*)
+
external failwith_from_ocaml : string -> 'a = "caml_failwith_value"
external dynamic_invalid_argument : unit -> 'a = "dynamic_invalid_argument"
$(OCAMLOPT) -w a -o $$F.native$(EXE) $$f; \
fi; \
done
- $(if $(findstring win32,$(UNIX_OR_WIN32)),:, \
- @grep -q HAS_STACK_OVERFLOW_DETECTION $(TOPDIR)/byterun/caml/s.h \
+ @$(if $(findstring win32,$(UNIX_OR_WIN32)),:, \
+ grep -q HAS_STACK_OVERFLOW_DETECTION $(TOPDIR)/byterun/caml/s.h \
|| rm -f stackoverflow.native$(EXE))
# Cygwin doesn't allow the stack limit to be changed - the 4096 is
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Jeremie Dimino, Jane Street Europe *
-#* *
-#* Copyright 2016 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-LIBRARIES=ocaml
-MODULES=foo cached_cmi
-MAIN_MODULE=main
-COMPFLAGS=-I $(OTOPDIR)/typing -I $(OTOPDIR)/toplevel
-LIBRARIES=../../../compilerlibs/ocamlcommon \
- ../../../compilerlibs/ocamlbytecomp \
- ../../../compilerlibs/ocamltoplevel
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
-
-BYTECODE_ONLY=true
-GENERATED_SOURCES+=cached_cmi.ml
-EXEC_ARGS=$(OCFLAGS) -noinit input.ml
-
-cached_cmi.ml: foo.cmi gen_cached_cmi.ml
- @$(OCAML) ../../../compilerlibs/ocamlcommon.cma -I $(OTOPDIR)/typing \
- gen_cached_cmi.ml > $@
let () =
let cmi = Cmi_format.read_cmi "foo.cmi" in
let data = Marshal.to_string cmi [] in
- Printf.printf "let foo = %S\n" data
+ let filename = Sys.argv.(1) in
+ let oc = open_out filename in
+ Printf.fprintf oc "let foo = %S\n" data;
+ close_out oc
+(* TEST
+files = "foo.ml gen_cached_cmi.ml input.ml"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+module = "foo.ml"
+*** ocaml with ocamlcommon
+ocaml_script_as_argument = "true"
+test_file = "gen_cached_cmi.ml"
+arguments = "cached_cmi.ml"
+**** ocamlc.byte
+module = ""
+program = "${test_build_directory}/main.exe"
+libraries += "ocamlbytecomp ocamltoplevel"
+all_modules = "foo.cmo cached_cmi.ml main.ml"
+***** run
+set OCAMLLIB="${ocamlsrcdir}/stdlib"
+arguments = "input.ml"
+****** check-program-output
+*)
+
let () =
(* Make sure it's no longer available on disk *)
if Sys.file_exists "foo.cmi" then Sys.remove "foo.cmi";
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Bernhard Schommer *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-
-
-default:
- @$(MAKE) byte
- @if $(BYTECODE_ONLY); then $(MAKE) opt-skipped ; else \
- $(MAKE) opt; \
- fi
-
-byte:
- @$(OCAMLC) unknown-file 2>&1 | grep "don't know what to do with unknown-file" \
- > unknown-file.byte.result || true
- @for file in *.byte.reference; do \
- printf " ... testing '$$file':"; \
- $(DIFF) $$file `basename $$file reference`result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done
-
-opt:
- @$(OCAMLOPT) unknown-file 2>&1 | grep "don't know what to do with unknown-file"\
- > unknown-file.opt.result || true
- @for file in *.opt.reference; do \
- printf " ... testing '$$file':"; \
- $(DIFF) $$file `basename $$file reference`result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done
-
-opt-skipped:
- @for file in *.opt.reference; do \
- printf " ... testing '$$file':"; \
- echo " => skipped"; \
- done
-
-promote: defaultpromote
-
-clean: defaultclean
- @rm -f *.result
-
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+(* TEST
+
+files = "unknown-file"
+
+* skip (* setup-ocamlc.byte-build-env *)
+** ocamlc.byte
+all_modules = ""
+flags = "unknown-file"
+ocamlc_byte_exit_status = "2"
+*** check-ocamlc.byte-output
+
+* skip (* setup-ocamlopt.byte-build-env *)
+** ocamlopt.byte
+all_modules = ""
+flags = "unknown-file"
+ocamlopt_byte_exit_status = "2"
+*** no-flambda
+**** check-ocamlopt.byte-output
+*** flambda
+**** check-ocamlopt.byte-output
+compiler_reference = "${test_source_directory}/test.ocamlopt.byte.flambda.reference"
+
+*)
+
+(* this file is just a test driver, the test does not contain real OCamlcode *)
+
--- /dev/null
+don't know what to do with unknown-file
+Usage: ocamlc <options> <files>
+Options are:
+ -a Build a library
+ -absname Show absolute filenames in error messages
+ -annot Save information in <filename>.annot
+ -bin-annot Save typedtree in <filename>.cmt
+ -c Compile only (do not link)
+ -cc <command> Use <command> as the C compiler and linker
+ -cclib <opt> Pass option <opt> to the C linker
+ -ccopt <opt> Pass option <opt> to the C compiler and linker
+ -color {auto|always|never} Enable or disable colors in compiler messages
+ The following settings are supported:
+ auto use heuristics to enable colors only if supported
+ always enable colors
+ never disable colors
+ The default setting is 'auto', and the current heuristic
+ checks that the TERM environment variable exists and is
+ not empty or "dumb", and that isatty(stderr) holds.
+ -compat-32 Check that generated bytecode can run on 32-bit platforms
+ -config Print configuration values and exit
+ -custom Link in custom mode
+ -dllib <lib> Use the dynamically-loaded library <lib>
+ -dllpath <dir> Add <dir> to the run-time search path for shared libraries
+ -dtypes (deprecated) same as -annot
+ -for-pack <ident> Generate code that can later be `packed' with
+ ocamlc -pack -o <ident>.cmo
+ -g Save debugging information
+ -i Print inferred interface
+ -I <dir> Add <dir> to the list of include directories
+ -impl <file> Compile <file> as a .ml file
+ -intf <file> Compile <file> as a .mli file
+ -intf-suffix <string> Suffix for interface files (default: .mli)
+ -intf_suffix <string> (deprecated) same as -intf-suffix
+ -keep-docs Keep documentation strings in .cmi files
+ -no-keep-docs Do not keep documentation strings in .cmi files (default)
+ -keep-locs Keep locations in .cmi files (default)
+ -no-keep-locs Do not keep locations in .cmi files
+ -labels Use commuting label mode
+ -linkall Link all modules, even unused ones
+ -make-runtime Build a runtime system with given C objects and libraries
+ -make_runtime (deprecated) same as -make-runtime
+ -modern (deprecated) same as -labels
+ -alias-deps Do record dependencies for module aliases
+ -no-alias-deps Do not record dependencies for module aliases
+ -app-funct Activate applicative functors
+ -no-app-funct Deactivate applicative functors
+ -no-check-prims Do not check runtime for primitives
+ -noassert Do not compile assertion checks
+ -noautolink Do not automatically link C libraries specified in .cma files
+ -nolabels Ignore non-optional labels in types
+ -nostdlib Do not add default directory to the list of include directories
+ -o <file> Set output file name to <file>
+ -opaque Does not generate cross-module optimization information
+ (reduces necessary recompilation on module change)
+ -open <module> Opens the module <module> before typing
+ -output-obj Output an object file instead of an executable
+ -output-complete-obj Output an object file, including runtime, instead of an executable
+ -pack Package the given .cmo files into one .cmo
+ -pp <command> Pipe sources through preprocessor <command>
+ -ppx <command> Pipe abstract syntax trees through preprocessor <command>
+ -plugin <plugin> Load dynamic plugin <plugin>
+ -principal Check principality of type inference
+ -no-principal Do not check principality of type inference (default)
+ -rectypes Allow arbitrary recursive types
+ -no-rectypes Do not allow arbitrary recursive types (default)
+ -runtime-variant <str> Use the <str> variant of the run-time system
+ -safe-string Make strings immutable (default)
+ -short-paths Shorten paths in types
+ -strict-sequence Left-hand part of a sequence must have type unit
+ -no-strict-sequence Left-hand part of a sequence need not have type unit (default)
+ -strict-formats Reject invalid formats accepted by legacy implementations
+ (Warning: Invalid formats may behave differently from
+ previous OCaml versions, and will become always-rejected
+ in future OCaml versions. You should always use this flag
+ to detect invalid formats so you can fix them.)
+ -no-strict-formats Accept invalid formats accepted by legacy implementations (default)
+ (Warning: Invalid formats may behave differently from
+ previous OCaml versions, and will become always-rejected
+ in future OCaml versions. You should never use this flag
+ and instead fix invalid formats.)
+ -thread (deprecated) same as -I +threads
+ -unboxed-types unannotated unboxable types will be unboxed
+ -no-unboxed-types unannotated unboxable types will not be unboxed (default)
+ -unsafe Do not compile bounds checking on array and string access
+ -unsafe-string Make strings mutable
+ -use-runtime <file> Generate bytecode for the given runtime system
+ -use_runtime <file> (deprecated) same as -use-runtime
+ -v Print compiler version and location of standard library and exit
+ -verbose Print calls to external commands
+ -version Print version and exit
+ --version Print version and exit
+ -vmthread Generate code that supports the threads library with VM-level
+ scheduling
+ -vnum Print version number and exit
+ -w <list> Enable or disable warnings according to <list>:
+ +<spec> enable warnings in <spec>
+ -<spec> disable warnings in <spec>
+ @<spec> enable warnings in <spec> and treat them as errors
+ <spec> can be:
+ <num> a single warning number
+ <num1>..<num2> a range of consecutive warning numbers
+ <letter> a predefined set
+ default setting is "+a-4-6-7-9-27-29-32..42-44-45-48-50-60"
+ -warn-error <list> Enable or disable error status for warnings according
+ to <list>. See option -w for the syntax of <list>.
+ Default setting is "-a+31"
+ -warn-help Show description of warning numbers
+ -where Print location of standard library and exit
+ - <file> Treat <file> as a file name (even if it starts with `-')
+ -nopervasives (undocumented)
+ -use-prims <file> (undocumented)
+ -dno-unique-ids (undocumented)
+ -dunique-ids (undocumented)
+ -dsource (undocumented)
+ -dparsetree (undocumented)
+ -dtypedtree (undocumented)
+ -drawlambda (undocumented)
+ -dlambda (undocumented)
+ -dinstr (undocumented)
+ -dtimings Print timings information for each pass
+ -dprofile Print performance information for each pass
+ The columns are: time alloc top-heap absolute-top-heap.
+ -args <file> Read additional newline-terminated command line arguments
+ from <file>
+ -args0 <file> Read additional null character terminated command line arguments
+from <file>
+ -depend <options> Compute dependencies (use 'ocamlc -depend -help' for details)
+ -help Display this list of options
+ --help Display this list of options
--- /dev/null
+don't know what to do with unknown-file
+Usage: ocamlopt <options> <files>
+Options are:
+ -fPIC Generate position-independent machine code (default)
+ -fno-PIC Generate position-dependent machine code
+ -a Build a library
+ -absname Show absolute filenames in error messages
+ -afl-instrument Enable instrumentation for afl-fuzz
+ -afl-inst-ratio Configure percentage of branches instrumented
+ (advanced, see afl-fuzz docs for AFL_INST_RATIO)
+ -annot Save information in <filename>.annot
+ -bin-annot Save typedtree in <filename>.cmt
+ -inline-branch-factor <n>|<round>=<n>[,...] Estimate the probability of a branch being cold as 1/(1+n) (used for inlining) (default 0.10)
+ -c Compile only (do not link)
+ -cc <command> Use <command> as the C compiler and linker
+ -cclib <opt> Pass option <opt> to the C linker
+ -ccopt <opt> Pass option <opt> to the C compiler and linker
+ -clambda-checks Instrument clambda code with closure and field access checks (for debugging the compiler)
+ -Oclassic Make inlining decisions at function definition time rather than at the call site (replicates previous behaviour of the compiler)
+ -color {auto|always|never} Enable or disable colors in compiler messages
+ The following settings are supported:
+ auto use heuristics to enable colors only if supported
+ always enable colors
+ never disable colors
+ The default setting is 'auto', and the current heuristic
+ checks that the TERM environment variable exists and is
+ not empty or "dumb", and that isatty(stderr) holds.
+ -compact Optimize code size rather than speed
+ -config Print configuration values and exit
+ -dtypes (deprecated) same as -annot
+ -for-pack <ident> Generate code that can later be `packed' with
+ ocamlopt -pack -o <ident>.cmx
+ -g Record debugging information for exception backtrace
+ -i Print inferred interface
+ -I <dir> Add <dir> to the list of include directories
+ -impl <file> Compile <file> as a .ml file
+ -inline <n>|<round>=<n>[,...] Aggressiveness of inlining (default 10.00, higher numbers mean more aggressive)
+ -inline-toplevel <n>|<round>=<n>[,...] Aggressiveness of inlining at toplevel (higher numbers mean more aggressive)
+ -inline-alloc-cost <n>|<round>=<n>[,...] The cost of not removing an allocation during inlining (default 7, higher numbers more costly)
+ -inline-branch-cost <n>|<round>=<n>[,...] The cost of not removing a conditional during inlining (default 5, higher numbers more costly)
+ -inline-call-cost <n>|<round>=<n>[,...] The cost of not removing a call during inlining (default 5, higher numbers more costly)
+ -inline-prim-cost <n>|<round>=<n>[,...] The cost of not removing a primitive during inlining (default 3, higher numbers more costly)
+ -inline-indirect-cost <n>|<round>=<n>[,...] The cost of not removing an indirect call during inlining (default 4, higher numbers more costly)
+ -inline-lifting-benefit <n>|<round>=<n>[,...] The benefit of lifting definitions to toplevel during inlining (default 1300, higher numbers more beneficial)
+ -inlining-report Emit `.<round>.inlining' file(s) (one per round) showing the inliner's decisions
+ -intf <file> Compile <file> as a .mli file
+ -intf-suffix <string> Suffix for interface files (default: .mli)
+ -keep-docs Keep documentation strings in .cmi files
+ -no-keep-docs Do not keep documentation strings in .cmi files (default)
+ -keep-locs Keep locations in .cmi files (default)
+ -no-keep-locs Do not keep locations in .cmi files
+ -labels Use commuting label mode
+ -linkall Link all modules, even unused ones
+ -inline-max-depth <n>|<round>=<n>[,...] Maximum depth of search for inlining opportunities inside inlined functions (default 1)
+ -alias-deps Do record dependencies for module aliases
+ -no-alias-deps Do not record dependencies for module aliases
+ -linscan Use the linear scan register allocator
+ -app-funct Activate applicative functors
+ -no-app-funct Deactivate applicative functors
+ -no-float-const-prop Deactivate constant propagation for floating-point operations
+ -noassert Do not compile assertion checks
+ -noautolink Do not automatically link C libraries specified in .cmxa files
+ -nodynlink Enable optimizations for code that will not be dynlinked
+ -nolabels Ignore non-optional labels in types
+ -nostdlib Do not add default directory to the list of include directories
+ -no-unbox-free-vars-of-closures Do not unbox variables that will appear inside function closures
+ -no-unbox-specialised-args Do not unbox arguments to which functions have been specialised
+ -o <file> Set output file name to <file>
+ -O2 Apply increased optimization for speed
+ -O3 Apply aggressive optimization for speed (may significantly increase code size and compilation time)
+ -opaque Does not generate cross-module optimization information
+ (reduces necessary recompilation on module change)
+ -open <module> Opens the module <module> before typing
+ -output-obj Output an object file instead of an executable
+ -output-complete-obj Output an object file, including runtime, instead of an executable
+ -p Compile and link with profiling support for "gprof"
+ (not supported on all platforms)
+ -pack Package the given .cmx files into one .cmx
+ -plugin <plugin> Load dynamic plugin <plugin>
+ -pp <command> Pipe sources through preprocessor <command>
+ -ppx <command> Pipe abstract syntax trees through preprocessor <command>
+ -principal Check principality of type inference
+ -no-principal Do not check principality of type inference (default)
+ -rectypes Allow arbitrary recursive types
+ -no-rectypes Do not allow arbitrary recursive types (default)
+ -remove-unused-arguments Remove unused function arguments
+ -rounds <n> Repeat tree optimization and inlining phases this many times (default 1). Rounds are numbered starting from zero.
+ -runtime-variant <str> Use the <str> variant of the run-time system
+ -S Keep intermediate assembly file
+ -safe-string Make strings immutable (default)
+ -shared Produce a dynlinkable plugin
+ -short-paths Shorten paths in types
+ -strict-sequence Left-hand part of a sequence must have type unit
+ -no-strict-sequence Left-hand part of a sequence need not have type unit (default)
+ -strict-formats Reject invalid formats accepted by legacy implementations
+ (Warning: Invalid formats may behave differently from
+ previous OCaml versions, and will become always-rejected
+ in future OCaml versions. You should always use this flag
+ to detect invalid formats so you can fix them.)
+ -no-strict-formats Accept invalid formats accepted by legacy implementations (default)
+ (Warning: Invalid formats may behave differently from
+ previous OCaml versions, and will become always-rejected
+ in future OCaml versions. You should never use this flag
+ and instead fix invalid formats.)
+ -thread (deprecated) same as -I +threads
+ -unbox-closures Pass free variables via specialised arguments rather than closures
+ -unbox-closures-factor <n > 0> Scale the size threshold above which unbox-closures will slow down indirect calls rather than duplicating a function (default 10)
+ -inline-max-unroll <n>|<round>=<n>[,...] Unroll recursive functions at most this many times (default 0)
+ -unboxed-types unannotated unboxable types will be unboxed
+ -no-unboxed-types unannotated unboxable types will not be unboxed (default)
+ -unsafe Do not compile bounds checking on array and string access
+ -unsafe-string Make strings mutable
+ -v Print compiler version and location of standard library and exit
+ -verbose Print calls to external commands
+ -version Print version and exit
+ --version Print version and exit
+ -vnum Print version number and exit
+ -w <list> Enable or disable warnings according to <list>:
+ +<spec> enable warnings in <spec>
+ -<spec> disable warnings in <spec>
+ @<spec> enable warnings in <spec> and treat them as errors
+ <spec> can be:
+ <num> a single warning number
+ <num1>..<num2> a range of consecutive warning numbers
+ <letter> a predefined set
+ default setting is "+a-4-6-7-9-27-29-32..42-44-45-48-50-60"
+ -warn-error <list> Enable or disable error status for warnings according
+ to <list>. See option -w for the syntax of <list>.
+ Default setting is "-a+31"
+ -warn-help Show description of warning numbers
+ -where Print location of standard library and exit
+ - <file> Treat <file> as a file name (even if it starts with `-')
+ -nopervasives (undocumented)
+ -dno-unique-ids (undocumented)
+ -dunique-ids (undocumented)
+ -dsource (undocumented)
+ -dparsetree (undocumented)
+ -dtypedtree (undocumented)
+ -drawlambda (undocumented)
+ -dlambda (undocumented)
+ -drawclambda (undocumented)
+ -dclambda (undocumented)
+ -dflambda Print Flambda terms
+ -drawflambda Print Flambda terms after closure conversion
+ -dflambda-invariants Check Flambda invariants around each pass
+ -dflambda-no-invariants Do not Check Flambda invariants around each pass
+ -dflambda-let <stamp> Print when the given Flambda [Let] is created
+ -dflambda-verbose Print Flambda terms including around each pass
+ -dcmm (undocumented)
+ -dsel (undocumented)
+ -dcombine (undocumented)
+ -dcse (undocumented)
+ -dlive (undocumented)
+ -davail Print register availability info when printing liveness
+ -drunavail Run register availability pass (for testing only; needs -g)
+ -dspill (undocumented)
+ -dsplit (undocumented)
+ -dinterf (undocumented)
+ -dprefer (undocumented)
+ -dalloc (undocumented)
+ -dreload (undocumented)
+ -dscheduling (undocumented)
+ -dlinear (undocumented)
+ -dinterval (undocumented)
+ -dstartup (undocumented)
+ -dtimings Print timings information for each pass
+ -dprofile Print performance information for each pass
+ The columns are: time alloc top-heap absolute-top-heap.
+ -dump-pass Record transformations performed by these passes:
+ unbox-closures unbox-specialised-args unbox-free-vars-of-closures
+ remove-free-vars-equal-to-args remove-unused-arguments unused-arguments
+ -args <file> Read additional newline-terminated command line arguments
+ from <file>
+ -args0 <file> Read additional null character terminated command line arguments
+from <file>
+ -depend <options> Compute dependencies (use 'ocamlopt -depend -help' for details)
+ -help Display this list of options
+ --help Display this list of options
--- /dev/null
+don't know what to do with unknown-file
+Usage: ocamlopt <options> <files>
+Options are:
+ -fPIC Generate position-independent machine code (default)
+ -fno-PIC Generate position-dependent machine code
+ -a Build a library
+ -absname Show absolute filenames in error messages
+ -afl-instrument Enable instrumentation for afl-fuzz
+ -afl-inst-ratio Configure percentage of branches instrumented
+ (advanced, see afl-fuzz docs for AFL_INST_RATIO)
+ -annot Save information in <filename>.annot
+ -bin-annot Save typedtree in <filename>.cmt
+ -inline-branch-factor <n>|<round>=<n>[,...] Estimate the probability of a branch being cold as 1/(1+n) (used for inlining) (default 0.10)
+ -c Compile only (do not link)
+ -cc <command> Use <command> as the C compiler and linker
+ -cclib <opt> Pass option <opt> to the C linker
+ -ccopt <opt> Pass option <opt> to the C compiler and linker
+ -clambda-checks Instrument clambda code with closure and field access checks (for debugging the compiler)
+ -Oclassic Make inlining decisions at function definition time rather than at the call site (replicates previous behaviour of the compiler)
+ -color {auto|always|never} Enable or disable colors in compiler messages
+ The following settings are supported:
+ auto use heuristics to enable colors only if supported
+ always enable colors
+ never disable colors
+ The default setting is 'auto', and the current heuristic
+ checks that the TERM environment variable exists and is
+ not empty or "dumb", and that isatty(stderr) holds.
+ -compact Optimize code size rather than speed
+ -config Print configuration values and exit
+ -dtypes (deprecated) same as -annot
+ -for-pack <ident> Generate code that can later be `packed' with
+ ocamlopt -pack -o <ident>.cmx
+ -g Record debugging information for exception backtrace
+ -i Print inferred interface
+ -I <dir> Add <dir> to the list of include directories
+ -impl <file> Compile <file> as a .ml file
+ -inline <n>|<round>=<n>[,...] Aggressiveness of inlining (default 1.25, higher numbers mean more aggressive)
+ -inline-toplevel <n>|<round>=<n>[,...] Aggressiveness of inlining at toplevel (higher numbers mean more aggressive)
+ -inline-alloc-cost <n>|<round>=<n>[,...] The cost of not removing an allocation during inlining (default 7, higher numbers more costly)
+ -inline-branch-cost <n>|<round>=<n>[,...] The cost of not removing a conditional during inlining (default 5, higher numbers more costly)
+ -inline-call-cost <n>|<round>=<n>[,...] The cost of not removing a call during inlining (default 5, higher numbers more costly)
+ -inline-prim-cost <n>|<round>=<n>[,...] The cost of not removing a primitive during inlining (default 3, higher numbers more costly)
+ -inline-indirect-cost <n>|<round>=<n>[,...] The cost of not removing an indirect call during inlining (default 4, higher numbers more costly)
+ -inline-lifting-benefit <n>|<round>=<n>[,...] The benefit of lifting definitions to toplevel during inlining (default 1300, higher numbers more beneficial)
+ -inlining-report Emit `.<round>.inlining' file(s) (one per round) showing the inliner's decisions
+ -intf <file> Compile <file> as a .mli file
+ -intf-suffix <string> Suffix for interface files (default: .mli)
+ -keep-docs Keep documentation strings in .cmi files
+ -no-keep-docs Do not keep documentation strings in .cmi files (default)
+ -keep-locs Keep locations in .cmi files (default)
+ -no-keep-locs Do not keep locations in .cmi files
+ -labels Use commuting label mode
+ -linkall Link all modules, even unused ones
+ -inline-max-depth <n>|<round>=<n>[,...] Maximum depth of search for inlining opportunities inside inlined functions (default 1)
+ -alias-deps Do record dependencies for module aliases
+ -no-alias-deps Do not record dependencies for module aliases
+ -linscan Use the linear scan register allocator
+ -app-funct Activate applicative functors
+ -no-app-funct Deactivate applicative functors
+ -no-float-const-prop Deactivate constant propagation for floating-point operations
+ -noassert Do not compile assertion checks
+ -noautolink Do not automatically link C libraries specified in .cmxa files
+ -nodynlink Enable optimizations for code that will not be dynlinked
+ -nolabels Ignore non-optional labels in types
+ -nostdlib Do not add default directory to the list of include directories
+ -no-unbox-free-vars-of-closures Do not unbox variables that will appear inside function closures
+ -no-unbox-specialised-args Do not unbox arguments to which functions have been specialised
+ -o <file> Set output file name to <file>
+ -O2 Apply increased optimization for speed
+ -O3 Apply aggressive optimization for speed (may significantly increase code size and compilation time)
+ -opaque Does not generate cross-module optimization information
+ (reduces necessary recompilation on module change)
+ -open <module> Opens the module <module> before typing
+ -output-obj Output an object file instead of an executable
+ -output-complete-obj Output an object file, including runtime, instead of an executable
+ -p Compile and link with profiling support for "gprof"
+ (not supported on all platforms)
+ -pack Package the given .cmx files into one .cmx
+ -plugin <plugin> Load dynamic plugin <plugin>
+ -pp <command> Pipe sources through preprocessor <command>
+ -ppx <command> Pipe abstract syntax trees through preprocessor <command>
+ -principal Check principality of type inference
+ -no-principal Do not check principality of type inference (default)
+ -rectypes Allow arbitrary recursive types
+ -no-rectypes Do not allow arbitrary recursive types (default)
+ -remove-unused-arguments Remove unused function arguments
+ -rounds <n> Repeat tree optimization and inlining phases this many times (default 1). Rounds are numbered starting from zero.
+ -runtime-variant <str> Use the <str> variant of the run-time system
+ -S Keep intermediate assembly file
+ -safe-string Make strings immutable (default)
+ -shared Produce a dynlinkable plugin
+ -short-paths Shorten paths in types
+ -strict-sequence Left-hand part of a sequence must have type unit
+ -no-strict-sequence Left-hand part of a sequence need not have type unit (default)
+ -strict-formats Reject invalid formats accepted by legacy implementations
+ (Warning: Invalid formats may behave differently from
+ previous OCaml versions, and will become always-rejected
+ in future OCaml versions. You should always use this flag
+ to detect invalid formats so you can fix them.)
+ -no-strict-formats Accept invalid formats accepted by legacy implementations (default)
+ (Warning: Invalid formats may behave differently from
+ previous OCaml versions, and will become always-rejected
+ in future OCaml versions. You should never use this flag
+ and instead fix invalid formats.)
+ -thread (deprecated) same as -I +threads
+ -unbox-closures Pass free variables via specialised arguments rather than closures
+ -unbox-closures-factor <n > 0> Scale the size threshold above which unbox-closures will slow down indirect calls rather than duplicating a function (default 10)
+ -inline-max-unroll <n>|<round>=<n>[,...] Unroll recursive functions at most this many times (default 0)
+ -unboxed-types unannotated unboxable types will be unboxed
+ -no-unboxed-types unannotated unboxable types will not be unboxed (default)
+ -unsafe Do not compile bounds checking on array and string access
+ -unsafe-string Make strings mutable
+ -v Print compiler version and location of standard library and exit
+ -verbose Print calls to external commands
+ -version Print version and exit
+ --version Print version and exit
+ -vnum Print version number and exit
+ -w <list> Enable or disable warnings according to <list>:
+ +<spec> enable warnings in <spec>
+ -<spec> disable warnings in <spec>
+ @<spec> enable warnings in <spec> and treat them as errors
+ <spec> can be:
+ <num> a single warning number
+ <num1>..<num2> a range of consecutive warning numbers
+ <letter> a predefined set
+ default setting is "+a-4-6-7-9-27-29-32..42-44-45-48-50-60"
+ -warn-error <list> Enable or disable error status for warnings according
+ to <list>. See option -w for the syntax of <list>.
+ Default setting is "-a+31"
+ -warn-help Show description of warning numbers
+ -where Print location of standard library and exit
+ - <file> Treat <file> as a file name (even if it starts with `-')
+ -nopervasives (undocumented)
+ -dno-unique-ids (undocumented)
+ -dunique-ids (undocumented)
+ -dsource (undocumented)
+ -dparsetree (undocumented)
+ -dtypedtree (undocumented)
+ -drawlambda (undocumented)
+ -dlambda (undocumented)
+ -drawclambda (undocumented)
+ -dclambda (undocumented)
+ -dflambda Print Flambda terms
+ -drawflambda Print Flambda terms after closure conversion
+ -dflambda-invariants Check Flambda invariants around each pass
+ -dflambda-no-invariants Do not Check Flambda invariants around each pass
+ -dflambda-let <stamp> Print when the given Flambda [Let] is created
+ -dflambda-verbose Print Flambda terms including around each pass
+ -dcmm (undocumented)
+ -dsel (undocumented)
+ -dcombine (undocumented)
+ -dcse (undocumented)
+ -dlive (undocumented)
+ -davail Print register availability info when printing liveness
+ -drunavail Run register availability pass (for testing only; needs -g)
+ -dspill (undocumented)
+ -dsplit (undocumented)
+ -dinterf (undocumented)
+ -dprefer (undocumented)
+ -dalloc (undocumented)
+ -dreload (undocumented)
+ -dscheduling (undocumented)
+ -dlinear (undocumented)
+ -dinterval (undocumented)
+ -dstartup (undocumented)
+ -dtimings Print timings information for each pass
+ -dprofile Print performance information for each pass
+ The columns are: time alloc top-heap absolute-top-heap.
+ -dump-pass Record transformations performed by these passes:
+ unbox-closures unbox-specialised-args unbox-free-vars-of-closures
+ remove-free-vars-equal-to-args remove-unused-arguments unused-arguments
+ -args <file> Read additional newline-terminated command line arguments
+ from <file>
+ -args0 <file> Read additional null character terminated command line arguments
+from <file>
+ -depend <options> Compute dependencies (use 'ocamlopt -depend -help' for details)
+ -help Display this list of options
+ --help Display this list of options
+++ /dev/null
-don't know what to do with unknown-file
+++ /dev/null
-don't know what to do with unknown-file
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Damien Doligez, EPI Gallium, INRIA Rocquencourt *
-#* *
-#* Copyright 2013 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../../..
-MAIN_MODULE=debuggee
-ADD_COMPFLAGS=-g -custom
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-
-.PHONY: default
-default:
- @if ! $(SUPPORTS_SHARED_LIBRARIES); then \
- echo 'skipped (shared libraries not available)'; \
- else \
- $(MAKE) compile; \
- $(SET_LD_PATH) OCAMLLIB=. $(MAKE) run; \
- fi
-
-.PHONY: compile
-compile: $(ML_FILES) $(CMO_FILES) $(MAIN_MODULE).cmo
- @rm -f program.byte program.byte.exe
- @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte$(EXE) \
- $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \
- $(MAIN_MODULE).cmo
- @mkdir -p compiler-libs
- @cp $(TOPDIR)/toplevel/topdirs.cmi compiler-libs/
-
-.PHONY: run
-run:
- @printf " ... testing with ocamlc"
- @rm -f $(MAIN_MODULE).result
- @echo 'source input_script' | \
- $(OCAMLRUN) `$(CYGPATH) $(TOPDIR)/debugger/ocamldebug$(EXE)` \
- program.byte$(EXE) >$(MAIN_MODULE).raw.result 2>&1 \
- && sed -e '/Debugger version/d' -e '/^Time:/d' -e '$$d' \
- $(MAIN_MODULE).raw.result >$(MAIN_MODULE).result \
- && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result >/dev/null \
- && echo " => passed" || echo " => failed"
-
-.PHONY: promote
-promote: defaultpromote
-
-.PHONY: clean
-clean: defaultclean
- @rm -f *.result program.byte program.byte.exe \
- program.native program.native.exe \
- $(GENERATED_SOURCES) $(O_FILES) $(TEST_TEMP_FILES)
- @rm -rf compiler-libs
-
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+set foo = "bar"
+flags += " -g "
+ocamldebug_script = "${test_source_directory}/input_script"
+* shared-libraries
+** setup-ocamlc.byte-build-env
+*** ocamlc.byte
+**** check-ocamlc.byte-output
+***** ocamldebug
+****** check-program-output
+*)
+
print_endline Sys.argv.(1);;
print_endline (Sys.getenv "foo");;
-
-(ocd) Loading program... done.
+Loading program... done.
arg1
notbar
Program exit.
--- /dev/null
+debuggee.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Damien Doligez, EPI Gallium, INRIA Rocquencourt *
-#* *
-#* Copyright 2013 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../../..
-MAIN_MODULE=debuggee
-ADD_COMPFLAGS=-g -custom
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-
-.PHONY: default
-default:
- @if ! $(SUPPORTS_SHARED_LIBRARIES); then \
- echo 'skipped (shared libraries not available)'; \
- else \
- $(MAKE) compile; \
- $(SET_LD_PATH) OCAMLLIB=. $(MAKE) run; \
- fi
-
-.PHONY: compile
-compile: $(ML_FILES) $(CMO_FILES)
- @rm -rf out
- @rm -f program.byte program.byte.exe
- @mkdir out
- @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o out/blah.cmo -c \
- $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \
- in/blah.ml
- @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o out/foo.cmo -c \
- $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \
- -I out in/foo.ml
- @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte$(EXE) \
- $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \
- out/blah.cmo out/foo.cmo
- @mkdir -p compiler-libs
- @cp $(TOPDIR)/toplevel/topdirs.cmi compiler-libs/
-
-.PHONY: run
-run:
- @printf " ... testing with ocamlc"
- @rm -f $(MAIN_MODULE).result
- @echo 'source input_script' | \
- $(OCAMLRUN) `$(CYGPATH) $(TOPDIR)/debugger/ocamldebug$(EXE)` \
- program.byte$(EXE) >$(MAIN_MODULE).raw.result 2>&1 \
- && sed -e '/Debugger version/d' -e '/^Time:/d' \
- -e '/Breakpoint [0-9]* at [0-9]*:/d' -e '$$d' \
- $(MAIN_MODULE).raw.result | tr -d '\r' >$(MAIN_MODULE).result \
- && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result >/dev/null \
- && echo " => passed" || echo " => failed"
-
-.PHONY: promote
-promote: defaultpromote
-
-.PHONY: clean
-clean: defaultclean
- @rm -f *.result program.byte program.byte.exe \
- program.native program.native.exe \
- $(GENERATED_SOURCES) $(O_FILES) $(TEST_TEMP_FILES)
- @rm -rf compiler-libs out
-
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+(* TEST
+ocamldebug_script = "${test_source_directory}/input_script"
+* shared-libraries
+** setup-ocamlc.byte-build-env
+*** script
+script = "mkdir out"
+**** ocamlc.byte
+flags = "-g -c"
+all_modules = "${test_source_directory}/in/blah.ml"
+program = "out/blah.cmo"
+***** ocamlc.byte
+program = "out/foo.cmo"
+flags = "-I out -g -c"
+all_modules = "${test_source_directory}/in/foo.ml"
+****** ocamlc.byte
+all_modules = "out/blah.cmo out/foo.cmo"
+flags = " -g "
+program = "debuggee.exe"
+******* check-ocamlc.byte-output
+******** ocamldebug
+********* check-program-output
+*)
+
+(* This file only contains the specification of how to run the test *)
-
-(ocd) Loading program... done.
+Loading program... done.
Breakpoint: 1
10 <|b|>print x;
x: Blah.blah = Foo
--- /dev/null
+debuggee.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Damien Doligez, EPI Gallium, INRIA Rocquencourt *
-#* *
-#* Copyright 2013 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../../..
-ADD_COMPFLAGS=-g -custom
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-
-.PHONY: default
-default:
- @if ! $(SUPPORTS_SHARED_LIBRARIES); then \
- echo 'skipped (shared libraries not available)'; \
- else \
- $(MAKE) compile; \
- $(SET_LD_PATH) OCAMLLIB=. $(MAKE) run; \
- fi
-
-.PHONY: compile
-compile: $(ML_FILES) $(CMO_FILES)
- @rm -f c$(EXE)
- @$(OCAMLC) $(ADD_COMPFLAGS) -c a.ml -for-pack foo
- @$(OCAMLC) $(ADD_COMPFLAGS) a.cmo -pack -o foo.cmo
- @$(OCAMLC) $(ADD_COMPFLAGS) -c b.ml
- @$(OCAMLC) $(ADD_COMPFLAGS) foo.cmo b.cmo -o c$(EXE)
- @mkdir -p compiler-libs
- @cp $(TOPDIR)/toplevel/topdirs.cmi compiler-libs/
-
-.PHONY: run
-run:
- @printf " ... testing with ocamlc"
- @rm -f noev.result
- @echo 'source input_script' | \
- $(OCAMLRUN) `$(CYGPATH) $(TOPDIR)/debugger/ocamldebug$(EXE)` \
- c$(EXE) >noev.raw.result 2>&1 \
- && sed -e '/Debugger version/d' -e '/^Time:/d' \
- -e '/Breakpoint [0-9]* at [0-9]*:/d' -e '$$d' \
- noev.raw.result >noev.result \
- && $(DIFF) noev.reference noev.result >/dev/null \
- && echo " => passed" || echo " => failed"
-
-.PHONY: promote
-promote: defaultpromote
-
-.PHONY: clean
-clean: defaultclean
- @rm -f *.result *.cm* c$(EXE)
- @rm -rf compiler-libs
-
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+(* TEST
+files = "a.ml b.ml"
+ocamldebug_script = "${test_source_directory}/input_script"
+* shared-libraries
+** setup-ocamlc.byte-build-env
+*** ocamlc.byte
+module = "a.ml"
+flags = "-g -for-pack foo"
+**** ocamlc.byte
+module = ""
+all_modules = "a.cmo"
+program = "foo.cmo"
+flags = "-g -pack"
+***** ocamlc.byte
+module = "b.ml"
+flags = " -g "
+****** ocamlc.byte
+module = ""
+flags = " -g "
+all_modules = "foo.cmo b.cmo"
+program = "${test_build_directory}/noev.exe"
+******* check-ocamlc.byte-output
+******** ocamldebug
+********* check-program-output
+*)
+
+(* This file only contains the specification of how to run the test *)
-
-(ocd) Loading program... done.
+Loading program... done.
1
Program exit.
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-MODULES=syntax gram_aux grammar scan_aux scanner lexgen output
-MAIN_MODULE=main
-LEX_MODULES=scanner
-YACC_MODULES=grammar
-ADD_COMPFLAGS=-w a
-EXEC_ARGS=input
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+14 shift/reduce conflicts, 2 reduce/reduce conflicts.
+(* TEST
+ modules = "syntax.ml gram_aux.ml grammar.mly scan_aux.ml scanner.mll lexgen.ml output.ml"
+ files = "input"
+ arguments = "input"
+ ocamllex_flags = " -q "
+ ocamlyacc_flags = " -q "
+ flags = " -w a "
+*)
+
(* The lexer generator. Command-line parsing. *)
open Syntax
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-SHOULD_FAIL=t060-raise.ml
-
-compile: lib.cmo
- @for file in t*.ml; do \
- printf " ... testing '$$file'"; \
- if [ `echo $(SHOULD_FAIL) | grep $$file` ]; then \
- $(OCAML) -w a lib.cmo $$file 2>/dev/null \
- && echo " => failed" || echo " => passed"; \
- else \
- $(OCAML) -w a lib.cmo $$file 2>/dev/null \
- && echo " => passed" || echo " => failed"; \
- fi; \
- done
-
-promote:
-
-clean: defaultclean
- @rm -f ./a.out
-
-include $(BASEDIR)/makefiles/Makefile.common
+++ /dev/null
-external raise : exn -> 'a = "%raise"
-
-external not : bool -> bool = "%boolnot"
-
-external (=) : 'a -> 'a -> bool = "%equal"
-external (<>) : 'a -> 'a -> bool = "%notequal"
-external (<) : 'a -> 'a -> bool = "%lessthan"
-external (>) : 'a -> 'a -> bool = "%greaterthan"
-external (<=) : 'a -> 'a -> bool = "%lessequal"
-external (>=) : 'a -> 'a -> bool = "%greaterequal"
-
-external (~-) : int -> int = "%negint"
-external (+) : int -> int -> int = "%addint"
-external (-) : int -> int -> int = "%subint"
-external ( * ) : int -> int -> int = "%mulint"
-external (/) : int -> int -> int = "%divint"
-external (mod) : int -> int -> int = "%modint"
-
-external (land) : int -> int -> int = "%andint"
-external (lor) : int -> int -> int = "%orint"
-external (lxor) : int -> int -> int = "%xorint"
-external (lsl) : int -> int -> int = "%lslint"
-external (lsr) : int -> int -> int = "%lsrint"
-external (asr) : int -> int -> int = "%asrint"
-
-external ignore : 'a -> unit = "%ignore"
-
-type 'a ref = { mutable contents: 'a }
-external ref : 'a -> 'a ref = "%makemutable"
-external (!) : 'a ref -> 'a = "%field0"
-external (:=) : 'a ref -> 'a -> unit = "%setfield0"
-external incr : int ref -> unit = "%incr"
-external decr : int ref -> unit = "%decr"
-
-type 'a option = None | Some of 'a
-
-type 'a weak_t;;
-external weak_create: int -> 'a weak_t = "caml_weak_create";;
-external weak_set : 'a weak_t -> int -> 'a option -> unit = "caml_weak_set";;
-external weak_get: 'a weak_t -> int -> 'a option = "caml_weak_get";;
-
-let x = 42;;
--- /dev/null
+t000.ml
+t010-const0.ml
+t010-const1.ml
+t010-const2.ml
+t010-const3.ml
+t011-constint.ml
+t020.ml
+t021-pushconst1.ml
+t021-pushconst2.ml
+t021-pushconst3.ml
+t022-pushconstint.ml
+t040-makeblock1.ml
+t040-makeblock2.ml
+t040-makeblock3.ml
+t041-makeblock.ml
+t050-getglobal.ml
+t050-pushgetglobal.ml
+t051-getglobalfield.ml
+t051-pushgetglobalfield.ml
+t060-raise.ml
+t070-branchif.ml
+t070-branchifnot.ml
+t070-branch.ml
+t071-boolnot.ml
+t080-eq.ml
+t080-geint.ml
+t080-gtint.ml
+t080-leint.ml
+t080-ltint.ml
+t080-neq.ml
+t090-acc0.ml
+t090-acc1.ml
+t090-acc2.ml
+t090-acc3.ml
+t090-acc4.ml
+t090-acc5.ml
+t090-acc6.ml
+t090-acc7.ml
+t091-acc.ml
+t092-pushacc0.ml
+t092-pushacc1.ml
+t092-pushacc2.ml
+t092-pushacc3.ml
+t092-pushacc4.ml
+t092-pushacc5.ml
+t092-pushacc6.ml
+t092-pushacc7.ml
+t092-pushacc.ml
+t093-pushacc.ml
+t100-pushtrap.ml
+t101-poptrap.ml
+t110-addint.ml
+t110-andint.ml
+t110-asrint-1.ml
+t110-asrint-2.ml
+t110-divint-1.ml
+t110-divint-2.ml
+t110-divint-3.ml
+t110-lslint.ml
+t110-lsrint.ml
+t110-modint-1.ml
+t110-modint-2.ml
+t110-mulint.ml
+t110-negint.ml
+t110-offsetint.ml
+t110-orint.ml
+t110-subint.ml
+t110-xorint.ml
+t120-getstringchar.ml
+t121-setstringchar.ml
+t130-getvectitem.ml
+t130-vectlength.ml
+t131-setvectitem.ml
+t140-switch-1.ml
+t140-switch-2.ml
+t140-switch-3.ml
+t140-switch-4.ml
+t141-switch-5.ml
+t141-switch-6.ml
+t141-switch-7.ml
+t142-switch-8.ml
+t142-switch-9.ml
+t142-switch-A.ml
+t150-push-1.ml
+t150-push-2.ml
+t160-closure.ml
+t161-apply1.ml
+t162-return.ml
+t163.ml
+t164-apply2.ml
+t164-apply3.ml
+t165-apply.ml
+t170-envacc2.ml
+t170-envacc3.ml
+t170-envacc4.ml
+t171-envacc.ml
+t172-pushenvacc1.ml
+t172-pushenvacc2.ml
+t172-pushenvacc3.ml
+t172-pushenvacc4.ml
+t173-pushenvacc.ml
+t180-appterm1.ml
+t180-appterm2.ml
+t180-appterm3.ml
+t181-appterm.ml
+t190-makefloatblock-1.ml
+t190-makefloatblock-2.ml
+t190-makefloatblock-3.ml
+t191-vectlength.ml
+t192-getfloatfield-1.ml
+t192-getfloatfield-2.ml
+t193-setfloatfield-1.ml
+t193-setfloatfield-2.ml
+t200-getfield0.ml
+t200-getfield1.ml
+t200-getfield2.ml
+t200-getfield3.ml
+t201-getfield.ml
+t210-setfield0.ml
+t210-setfield1.ml
+t210-setfield2.ml
+t210-setfield3.ml
+t211-setfield.ml
+t220-assign.ml
+t230-check_signals.ml
+t240-c_call1.ml
+t240-c_call2.ml
+t240-c_call3.ml
+t240-c_call4.ml
+t240-c_call5.ml
+t250-closurerec-1.ml
+t250-closurerec-2.ml
+t251-pushoffsetclosure0.ml
+t251-pushoffsetclosure2.ml
+t251-pushoffsetclosurem2.ml
+t252-pushoffsetclosure.ml
+t253-offsetclosure0.ml
+t253-offsetclosure2.ml
+t253-offsetclosurem2.ml
+t254-offsetclosure.ml
+t260-offsetref.ml
+t270-push_retaddr.ml
+t300-getmethod.ml
+t301-object.ml
+t310-alloc-1.ml
+t310-alloc-2.ml
+t320-gc-1.ml
+t320-gc-2.ml
+t320-gc-3.ml
+t330-compact-1.ml
+t330-compact-2.ml
+t330-compact-3.ml
+t330-compact-4.ml
+t340-weak.ml
+t350-heapcheck.ml
+t360-stacks-1.ml
+t360-stacks-2.ml
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
(* empty file *)
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
0;;
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
1;;
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
2;;
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
3;;
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
4;;
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
let _ = () in ();;
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
let _ = () in 1;;
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
let _ = () in 2;;
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
let _ = () in 3;;
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
let _ = () in -1;;
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
type t = {
mutable a : int;
};;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
type t = {
mutable a : int;
mutable b : int;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
type t = {
mutable a : int;
mutable b : int;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
type t = {
mutable a : int;
mutable b : int;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
[1];;
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
let _ = () in 0.01;;
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
Lib.x;;
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
let _ = () in Lib.x;;
(**
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+ocaml_exit_status = "2"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
raise End_of_file;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if true then 0 else raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if not false then 0 else raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if false then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if not true then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if not (0 = 0) then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if not (0 >= 0) then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if 0 > 0 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if not (0 <= 0) then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if 0 < 0 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if 0 <> 0 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = true in
();
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = true in
let y = false in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = true in
let y = false in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = true in
let y = false in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = true in
let y = false in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = true in
let y = false in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = true in
let y = false in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = true in
let y = false in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = true in
let y = false in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = false in
let y = true in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = false in
if x then raise Not_found
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = false in
let y = true in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = false in
let y = true in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = false in
let y = true in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = false in
let y = true in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = false in
let y = true in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = false in
let y = true in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = false in
let y = true in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = false in
let y = true in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
try raise Not_found
with _ -> ()
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
try ()
with _ -> ()
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 1 in
if 1 + x <> 2 then raise Not_found
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if (3 land 6) <> 2 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if (-2 asr 1) <> -1 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if (3 asr 1) <> 1 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if 2 / 2 <> 1 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if 3 / 2 <> 1 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
try
ignore (3 / 0);
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if (3 lsl 2) <> 12 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if (14 lsr 2) <> 3 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if 20 mod 3 <> 2 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
try
ignore (2 mod 0);
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if 2 * 2 <> 4 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 1 in
if -x <> -1 then raise Not_found
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if 2 + 2 <> 4 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if (3 lor 6) <> 7 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 1 in
if 1 - x <> 0 then raise Not_found
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if (3 lxor 6) <> 5 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if "foo".[2] <> 'o' then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = Bytes.of_string "foo" in
x.[2] <- 'x';
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if [| 1; 2 |].(1) <> 2 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if Array.length [| 1; 2 |] <> 2 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = [| 1; 2 |] in
x.(0) <- 3;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
match 0 with
| 0 -> ()
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
match 1 with
| 0 -> raise Not_found
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
match 2 with
| 0 -> raise Not_found
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
match -1 with
| 0 -> raise Not_found
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t =
| A of int
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t =
| A of int
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t =
| A of int
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t =
| A
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t =
| A
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t =
| A
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let _ = 0 in
try 0 with _ -> 0
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 1 in
try if x <> 1 then raise Not_found
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let f () = ();;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let f _ = raise End_of_file in
try
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let f _ = 0 in f 0;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let f _ _ = 0 in f 0;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let f _ _ = 0 in f 0 0;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let f _ _ _ = 0 in f 0 0 0;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let f _ _ _ _ = 0 in f 0 0 0 0;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 5 in
let y = 2 in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 5 in
let y = 2 in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 5 in
let y = 2 in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 5 in
let y = 2 in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 5 in
let f _ = x + x in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 5 in
let y = 4 in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 5 in
let y = 4 in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 5 in
let y = 4 in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 5 in
let y = 4 in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let f _ = 12 in
let g _ = f 0 in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let f _ _ = 12 in
let g _ = f 0 0 in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let f _ _ _ = 13 in
let g _ = f 0 0 0 in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let f _ _ _ _ = -10 in
let g _ = f 0 0 0 0 in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 0.0 in [| x |];;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 0.0 in [| x; x |];;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 0.0 in [| x; x; x |];;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = 0.0 in
if Array.length [| x |] <> 1 then raise Not_found
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t = { a : float; b : float };;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t = { a : float; b : float };;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t = {
mutable a : float;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t = {
mutable a : float;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t = {
a : int;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t = {
a : int;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t = {
a : int;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t = {
a : int;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t = {
a : int;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t = {
mutable a : int;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t = {
mutable a : int;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t = {
mutable a : int;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t = {
mutable a : int;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
type t = {
mutable a : int;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = ref 1 in
x := 3;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
for i = 0 to 0 do () done;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if Pervasives.int_of_string "123" <> 123 then raise Not_found;;
(** test for fix of bug 6649: http://caml.inria.fr/mantis/view.php?id=6649 *)
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if Pervasives.compare 1 2 <> -1 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
if Hashtbl.hash_param 5 6 [1;2;3] <> 697606130 then raise Not_found;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let s = Bytes.of_string "abcdefgh" in
Bytes.unsafe_fill s 0 6 'x';
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let s = Bytes.of_string "abcdefgh" in
Bytes.unsafe_blit s 3 s 0 3;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f _ = 0;;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f _ = 23 in
if f 0 <> 23 then raise Not_found
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f = function
| 0 -> 13
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f _ = g 0
and g _ = 4
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f _ = 4
and g _ = f 2
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f x = x
and g _ = f 4
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f _ = g f
and g _ = 10
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f _ = g
and g _ = 10
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f _ = 11
and g _ = f
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f _ = 11
and g _ = 0
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = ref 32 in
incr x;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let f a b c d = 123 in
if f 0 1 2 3 <> 123 then raise Not_found
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
class c = object
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
(**** file testinterp/t301-object.ml
suggested by Jacques Garrigue to Basile Starynkevitch
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f a n =
if n <= 0 then a
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let v = Array.make 200000 2 in
let t = ref 0 in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f n =
if n <= 0 then []
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f n =
if n <= 0 then []
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f n =
if n <= 0 then []
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
Gc.compact ();;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
Gc.compact ();;
let _ = Pervasives.do_at_exit();;
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f n =
if n <= 0 then []
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f n =
if n <= 0 then []
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let x = Array.make 20 "" in
let w = weak_create 20 in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
ignore (Gc.stat ());
let x = Array.make 20 "" in
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f n =
if n <= 0 then 12
+(* TEST
+include tool-ocaml-lib
+flags = "-w a"
+ocaml_script_as_argument = "true"
+* setup-ocaml-build-env
+** ocaml
+*)
+
open Lib;;
let rec f n =
if n <= 0 then 12
+++ /dev/null
-BASEDIR=../..
-
-.PHONY: default
-default:
- @printf " ... testing -compat-32"
- @if ($(OCAMLC) -config | grep "word_size: *64") \
- then $(MAKE) run; \
- else echo ' => skipped (not compiled in 64bit)'; \
- fi
-
-.PHONY: run
-run:
- @$(OCAMLC) -compat-32 -c a.ml > test.result 2>&1 || true
- @$(OCAMLC) -c a.ml
- @$(OCAMLC) -compat-32 -a a.cmo -o a.cma >> test.result 2>&1 || true
- @$(OCAMLC) -a a.cmo -o a.cma
- @$(OCAMLC) -compat-32 a.cma -o a.byte -linkall >> test.result 2>&1 || true
- @$(DIFF) test.reference test.result >/dev/null \
- && echo " => passed" || echo " => failed"; \
-
-promote: defaultpromote
-
-clean: defaultclean
-
-include $(BASEDIR)/makefiles/Makefile.common
+++ /dev/null
-let a = 0xffffffffffff
--- /dev/null
+File "compat32.ml", line 1:
+Error: Generated bytecode unit "compat32.cmo" cannot be used on a 32-bit platform
+File "_none_", line 1:
+Error: Generated bytecode library "compat32.cma" cannot be used on a 32-bit platform
+File "_none_", line 1:
+Error: Generated bytecode executable "compat32.byte" cannot be used on a 32-bit platform
--- /dev/null
+(* TEST
+ * arch64
+ ** setup-ocamlc.byte-build-env
+ *** ocamlc.byte
+ compile_only = "true"
+ flags = "-compat-32"
+ ocamlc_byte_exit_status = "2"
+ **** ocamlc.byte
+ ocamlc_byte_exit_status = "0"
+ flags = ""
+ ***** ocamlc.byte
+ compile_only = "false"
+ all_modules = "compat32.cmo"
+ flags = "-compat-32 -a"
+ program = "compat32.cma"
+ ocamlc_byte_exit_status = "2"
+ ****** ocamlc.byte
+ flags = "-a"
+ program = "compat32.cma"
+ ocamlc_byte_exit_status = "0"
+ ******* ocamlc.byte
+ all_modules = "compat32.cma"
+ flags = "-compat-32 -linkall"
+ program = "compat32.byte"
+ ocamlc_byte_exit_status = "2"
+ ******** check-ocamlc.byte-output
+*)
+
+let a = 0xffffffffffff
--- /dev/null
+compat32.ml
+++ /dev/null
-File "a.ml", line 1:
-Error: Generated bytecode unit "a.cmo" cannot be used on a 32-bit platform
-File "_none_", line 1:
-Error: Generated bytecode library "a.cma" cannot be used on a 32-bit platform
-File "_none_", line 1:
-Error: Generated bytecode executable "a.byte" cannot be used on a 32-bit platform
+++ /dev/null
-BASEDIR=../..
-
-compile:
- @printf " ... testing 'foo.ml'"
- @$(OCAMLC) -c a.ml
- @$(OCAMLC) -open A.M -c b.ml \
- && echo " => passed" || echo " => failed"
-
-promote:
-
-clean:
- @rm -f a.cmi a.cmo b.cmi b.cmo
-
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+tool-ocamlc-open.ml
--- /dev/null
+(* TEST
+files = "a.ml b.ml"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+module = "a.ml"
+*** ocamlc.byte
+module = "b.ml"
+flags = "-open A.M"
+**** check-ocamlc.byte-output
+*)
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-COMPFLAGS=-I $(OTOPDIR)/ocamldoc
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
-DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)\
- -latextitle "1,subsection*" \
- -latextitle "2,subsubsection*" \
- -latextitle "6,subsection*" \
- -latextitle "7,subsubsection*" \
- -latex-type-prefix "TYP" \
- -latex-module-prefix "" \
- -latex-module-type-prefix "" \
- -latex-value-prefix ""
-
-.PHONY: default
-default:
- @if ! $(SUPPORTS_SHARED_LIBRARIES); then \
- echo 'skipped (shared libraries not available)'; \
- else \
- $(SET_LD_PATH) $(MAKE) run; \
- fi
-
-.PHONY: run
-run: *.ml *.mli *.txt
- @for file in *.mli *.ml *.txt; do \
- printf " ... testing '$$file'"; \
- F="`basename $$file .mli`"; \
- F="`basename $$F .ml`"; \
- F="`basename $$F .txt`"; \
- $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -latex $ \
- -o $$F.result $$file; \
- $(DIFF) $$F.reference $$F.result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done
-
-.PHONY: promote
-promote: defaultpromote
-
-.PHONY: clean
-clean: defaultclean
- @rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux
-
-include $(BASEDIR)/makefiles/Makefile.common
+++ /dev/null
-(** Testing display of extensible variant types and exceptions.
-
- @test_types_display
- *)
-
-(** Also check reference for {!M.A}, {!M.B}, {!M.C} and {!E} *)
-
-(** Extensible type *)
-type e = ..
-
-module M = struct
- type e +=
- | A (** A doc *)
- | B (** B doc *)
- | C (** C doc *)
-end
-
-module type MT = sig
- type e +=
- | A (** A doc *)
- | B (** B doc *)
- | C (** C doc *)
-end
-
-exception E
+++ /dev/null
-\documentclass[11pt]{article}
-\usepackage[latin1]{inputenc}
-\usepackage[T1]{fontenc}
-\usepackage{textcomp}
-\usepackage{fullpage}
-\usepackage{url}
-\usepackage{ocamldoc}
-\begin{document}
-\tableofcontents
-\section{Module {\tt{Extensible\_variant}} : Testing display of extensible variant types and exceptions.}
-\label{Extensible-underscorevariant}\index{Extensible-underscorevariant@\verb`Extensible_variant`}
-
-
-
-
-\ocamldocvspace{0.5cm}
-
-
-
-Also check reference for {\tt{Extensible\_variant.M.A}}[\ref{extension:Extensible-underscorevariant.M.A}], {\tt{Extensible\_variant.M.B}}[\ref{extension:Extensible-underscorevariant.M.B}], {\tt{Extensible\_variant.M.C}}[\ref{extension:Extensible-underscorevariant.M.C}] and {\tt{Extensible\_variant.E}}[\ref{exception:Extensible-underscorevariant.E}]
-
-
-
-\label{TYPExtensible-underscorevariant.e}\begin{ocamldoccode}
-type e = ..
-\end{ocamldoccode}
-\index{e@\verb`e`}
-\begin{ocamldocdescription}
-Extensible type
-
-
-\end{ocamldocdescription}
-
-
-
-
-\begin{ocamldoccode}
-{\tt{module }}{\tt{M}}{\tt{ : }}\end{ocamldoccode}
-\label{Extensible-underscorevariant.M}\index{M@\verb`M`}
-
-\begin{ocamldocsigend}
-
-
-\begin{ocamldoccode}
-type e +=
-\end{ocamldoccode}
-\label{extension:Extensible-underscorevariant.M.A}\begin{ocamldoccode}
- | A
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-A doc
-
-
-\end{ocamldoccomment}
-\label{extension:Extensible-underscorevariant.M.B}\begin{ocamldoccode}
- | B
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-B doc
-
-
-\end{ocamldoccomment}
-\label{extension:Extensible-underscorevariant.M.C}\begin{ocamldoccode}
- | C
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-C doc
-
-
-\end{ocamldoccomment}
-\end{ocamldocsigend}
-
-
-
-
-
-
-\begin{ocamldoccode}
-{\tt{module type }}{\tt{MT}}{\tt{ = }}\end{ocamldoccode}
-\label{Extensible-underscorevariant.MT}\index{MT@\verb`MT`}
-
-\begin{ocamldocsigend}
-
-
-\begin{ocamldoccode}
-type e +=
-\end{ocamldoccode}
-\label{extension:Extensible-underscorevariant.MT.A}\begin{ocamldoccode}
- | A
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-A doc
-
-
-\end{ocamldoccomment}
-\label{extension:Extensible-underscorevariant.MT.B}\begin{ocamldoccode}
- | B
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-B doc
-
-
-\end{ocamldoccomment}
-\label{extension:Extensible-underscorevariant.MT.C}\begin{ocamldoccode}
- | C
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-C doc
-
-
-\end{ocamldoccomment}
-\end{ocamldocsigend}
-
-
-
-
-
-
-\label{exception:Extensible-underscorevariant.E}\begin{ocamldoccode}
-exception E
-\end{ocamldoccode}
-\index{E@\verb`E`}
-
-
-\end{document}
+++ /dev/null
-(**
- This test focuses on the printing of documentation for inline record
- within the latex generator.
-*)
-
-
-(** A nice exception *)
-exception Simple
-
-(** A less simple exception *)
-exception Less of int
-
-(** An open sum type *)
-type ext = ..
-
-(** A simple record type for reference *)
-type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
- more:int list (** More documentation for r, [more : int list] *) }
-
-
-(** A sum type with one inline record *)
-type t = A of {lbl: int (** [A] field documentation *)
- ; more:int list (** More [A] field documentation *) }
-(** Constructor documentation *)
-
-(** A sum type with two inline records *)
-type s =
- | B of { a_label_for_B : int (** [B] field documentation *);
- more_label_for_B:int list (** More [B] field documentation *) }
- (** Constructor B documentation *)
- | C of { c_has_label_too: float (** [C] field documentation*);
- more_than_one: unit (** ... documentations *) }
- (** Constructor C documentation *)
-
-(** A gadt constructor *)
-type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
-(** Constructor D documentation *)
-
-exception Error of {name:string (** Error field documentation [name:string] *) }
-
-type ext +=
- | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
- (** Constructor E documentation *)
- | F of { even_more: int -> int (** Some field documentations for [F] *) }
- (** Constructor F documentation *)
- | G of { last: int -> int (** The last and least field documentation *) }
- (** Constructor G documentation *)
-(** Two new constructors for ext *)
+++ /dev/null
-\documentclass[11pt]{article}
-\usepackage[latin1]{inputenc}
-\usepackage[T1]{fontenc}
-\usepackage{textcomp}
-\usepackage{fullpage}
-\usepackage{url}
-\usepackage{ocamldoc}
-\begin{document}
-\tableofcontents
-\section{Module {\tt{Inline\_records}} : This test focuses on the printing of documentation for inline record
- within the latex generator.}
-\label{Inline-underscorerecords}\index{Inline-underscorerecords@\verb`Inline_records`}
-
-
-
-
-\ocamldocvspace{0.5cm}
-
-
-
-\label{exception:Inline-underscorerecords.Simple}\begin{ocamldoccode}
-exception Simple
-\end{ocamldoccode}
-\index{Simple@\verb`Simple`}
-\begin{ocamldocdescription}
-A nice exception
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{exception:Inline-underscorerecords.Less}\begin{ocamldoccode}
-exception Less of int
-\end{ocamldoccode}
-\index{Less@\verb`Less`}
-\begin{ocamldocdescription}
-A less simple exception
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPInline-underscorerecords.ext}\begin{ocamldoccode}
-type ext = ..
-\end{ocamldoccode}
-\index{ext@\verb`ext`}
-\begin{ocamldocdescription}
-An open sum type
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPInline-underscorerecords.r}\begin{ocamldoccode}
-type r =
-{\char123} lbl : int ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Field documentation for non-inline, {\tt{lbl : int}}
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- more : int list ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-More documentation for r, {\tt{more : int list}}
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\index{r@\verb`r`}
-\begin{ocamldocdescription}
-A simple record type for reference
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPInline-underscorerecords.t}\begin{ocamldoccode}
-type t =
- | A of {\char123} lbl : int ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-{\tt{A}} field documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- more : int list ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-More {\tt{A}} field documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Constructor documentation
-
-
-\end{ocamldoccomment}
-\index{t@\verb`t`}
-\begin{ocamldocdescription}
-A sum type with one inline record
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPInline-underscorerecords.s}\begin{ocamldoccode}
-type s =
- | B of {\char123} a_label_for_B : int ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-{\tt{B}} field documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- more_label_for_B : int list ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-More {\tt{B}} field documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Constructor B documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- | C of {\char123} c_has_label_too : float ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-{\tt{C}} field documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- more_than_one : unit ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-$\ldots$ documentations
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Constructor C documentation
-
-
-\end{ocamldoccomment}
-\index{s@\verb`s`}
-\begin{ocamldocdescription}
-A sum type with two inline records
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPInline-underscorerecords.any}\begin{ocamldoccode}
-type any =
- | D : {\char123} any : {\textquotesingle}a ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-{\tt{A}} field {\tt{any:{\textquotesingle}a}} for {\tt{D}} in {\tt{any}}.
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
- ->
-any
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Constructor D documentation
-
-
-\end{ocamldoccomment}
-\index{any@\verb`any`}
-\begin{ocamldocdescription}
-A gadt constructor
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{exception:Inline-underscorerecords.Error}\begin{ocamldoccode}
-exception Error of {\char123} name : string ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Error field documentation {\tt{name:string}}
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\index{Error@\verb`Error`}
-
-
-
-
-\begin{ocamldoccode}
-type ext +=
-\end{ocamldoccode}
-\label{extension:Inline-underscorerecords.E}\begin{ocamldoccode}
- | E of {\char123} yet_another_field : unit ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Field documentation for {\tt{E}} in ext
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Constructor E documentation
-
-
-\end{ocamldoccomment}
-\label{extension:Inline-underscorerecords.F}\begin{ocamldoccode}
- | F of {\char123} even_more : int -> int ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Some field documentations for {\tt{F}}
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Constructor F documentation
-
-
-\end{ocamldoccomment}
-\label{extension:Inline-underscorerecords.G}\begin{ocamldoccode}
- | G of {\char123} last : int -> int ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-The last and least field documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Constructor G documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldocdescription}
-Two new constructors for ext
-
-
-\end{ocamldocdescription}
-
-
-\end{document}
+++ /dev/null
-(**
- This test focuses on the printing of documentation for inline record
- within the latex generator.
-*)
-
-
-(** A nice exception *)
-exception Simple
-
-(** A less simple exception *)
-exception Less of int
-
-(** An open sum type *)
-type ext = ..
-
-(** A simple record type for reference *)
-type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
- more:int list (** More documentation for r, [more : int list] *) }
-
-
-(** A sum type with one inline record *)
-type t = A of {lbl: int (** [A] field documentation *)
- ; more:int list (** More [A] field documentation *) }
-(** Constructor documentation *)
-
-(** A sum type with two inline records *)
-type s =
- | B of { a_label_for_B : int (** [B] field documentation *);
- more_label_for_B:int list (** More [B] field documentation *) }
- (** Constructor B documentation *)
- | C of { c_has_label_too: float (** [C] field documentation*);
- more_than_one: unit (** ... documentations *) }
- (** Constructor C documentation *)
-
-(** A gadt constructor *)
-type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
-(** Constructor D documentation *)
-
-exception Error of {name:string (** Error field documentation [name:string] *) }
-
-type ext +=
- | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
- (** Constructor E documentation *)
- | F of { even_more: int -> int (** Some field documentations for [F] *) }
- (** Constructor F documentation *)
- | G of { last: int -> int (** The last and least field documentation *) }
- (** Constructor G documentation *)
-(** Two new constructors for ext *)
+++ /dev/null
-\documentclass[11pt]{article}
-\usepackage[latin1]{inputenc}
-\usepackage[T1]{fontenc}
-\usepackage{textcomp}
-\usepackage{fullpage}
-\usepackage{url}
-\usepackage{ocamldoc}
-\begin{document}
-\tableofcontents
-\section{Module {\tt{Inline\_records\_bis}} : This test focuses on the printing of documentation for inline record
- within the latex generator.}
-\label{Inline-underscorerecords-underscorebis}\index{Inline-underscorerecords-underscorebis@\verb`Inline_records_bis`}
-
-
-
-
-\ocamldocvspace{0.5cm}
-
-
-
-\label{exception:Inline-underscorerecords-underscorebis.Simple}\begin{ocamldoccode}
-exception Simple
-\end{ocamldoccode}
-\index{Simple@\verb`Simple`}
-\begin{ocamldocdescription}
-A nice exception
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{exception:Inline-underscorerecords-underscorebis.Less}\begin{ocamldoccode}
-exception Less of int
-\end{ocamldoccode}
-\index{Less@\verb`Less`}
-\begin{ocamldocdescription}
-A less simple exception
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPInline-underscorerecords-underscorebis.ext}\begin{ocamldoccode}
-type ext = ..
-\end{ocamldoccode}
-\index{ext@\verb`ext`}
-\begin{ocamldocdescription}
-An open sum type
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPInline-underscorerecords-underscorebis.r}\begin{ocamldoccode}
-type r =
-{\char123} lbl : int ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Field documentation for non-inline, {\tt{lbl : int}}
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- more : int list ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-More documentation for r, {\tt{more : int list}}
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\index{r@\verb`r`}
-\begin{ocamldocdescription}
-A simple record type for reference
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPInline-underscorerecords-underscorebis.t}\begin{ocamldoccode}
-type t =
- | A of {\char123} lbl : int ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-{\tt{A}} field documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- more : int list ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-More {\tt{A}} field documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Constructor documentation
-
-
-\end{ocamldoccomment}
-\index{t@\verb`t`}
-\begin{ocamldocdescription}
-A sum type with one inline record
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPInline-underscorerecords-underscorebis.s}\begin{ocamldoccode}
-type s =
- | B of {\char123} a_label_for_B : int ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-{\tt{B}} field documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- more_label_for_B : int list ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-More {\tt{B}} field documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Constructor B documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- | C of {\char123} c_has_label_too : float ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-{\tt{C}} field documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- more_than_one : unit ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-$\ldots$ documentations
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Constructor C documentation
-
-
-\end{ocamldoccomment}
-\index{s@\verb`s`}
-\begin{ocamldocdescription}
-A sum type with two inline records
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPInline-underscorerecords-underscorebis.any}\begin{ocamldoccode}
-type any =
- | D : {\char123} any : {\textquotesingle}a ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-{\tt{A}} field {\tt{any:{\textquotesingle}a}} for {\tt{D}} in {\tt{any}}.
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
- ->
-any
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Constructor D documentation
-
-
-\end{ocamldoccomment}
-\index{any@\verb`any`}
-\begin{ocamldocdescription}
-A gadt constructor
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{exception:Inline-underscorerecords-underscorebis.Error}\begin{ocamldoccode}
-exception Error of {\char123} name : string ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Error field documentation {\tt{name:string}}
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\index{Error@\verb`Error`}
-
-
-
-
-\begin{ocamldoccode}
-type ext +=
-\end{ocamldoccode}
-\label{extension:Inline-underscorerecords-underscorebis.E}\begin{ocamldoccode}
- | E of {\char123} yet_another_field : unit ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Field documentation for {\tt{E}} in ext
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Constructor E documentation
-
-
-\end{ocamldoccomment}
-\label{extension:Inline-underscorerecords-underscorebis.F}\begin{ocamldoccode}
- | F of {\char123} even_more : int -> int ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Some field documentations for {\tt{F}}
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Constructor F documentation
-
-
-\end{ocamldoccomment}
-\label{extension:Inline-underscorerecords-underscorebis.G}\begin{ocamldoccode}
- | G of {\char123} last : int -> int ;
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-The last and least field documentation
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
-{\char125}
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-Constructor G documentation
-
-
-\end{ocamldoccomment}
-
-
-
-
-Two new constructors for ext
-
-\end{document}
+++ /dev/null
-(** Test for level 0 headings
-
- {1 Level 1}
-
- Standard heading levels start at 1.
-
- {0 Level 0}
- A level 0 heading is guaranted to be at the same level that
- the main heading of the module.
-
- This setup allows users to start their standard heading at level 1 rather
- than 2, without losing the ability to add global level heading,
- when, if ever, such heading is warranted
-
- *)
+++ /dev/null
-\documentclass[11pt]{article}
-\usepackage[latin1]{inputenc}
-\usepackage[T1]{fontenc}
-\usepackage{textcomp}
-\usepackage{fullpage}
-\usepackage{url}
-\usepackage{ocamldoc}
-\begin{document}
-\tableofcontents
-\section{Module {\tt{Level\_0}} : Test for level 0 headings }
-\label{Level-underscore0}\index{Level-underscore0@\verb`Level_0`}
-
-
-
- \subsection*{Level 1}
-
-
-
- Standard heading levels start at 1.
-
-
- \section{Level 0}
-
- A level 0 heading is guaranted to be at the same level that
- the main heading of the module.
-
-
- This setup allows users to start their standard heading at level 1 rather
- than 2, without losing the ability to add global level heading,
- when, if ever, such heading is warranted
-
-
-
-\ocamldocvspace{0.5cm}
-
-\end{document}
+++ /dev/null
-
-module rec A : sig type t end = B and B : sig type t = A.t end = A;;
-
+++ /dev/null
-\documentclass[11pt]{article}
-\usepackage[latin1]{inputenc}
-\usepackage[T1]{fontenc}
-\usepackage{textcomp}
-\usepackage{fullpage}
-\usepackage{url}
-\usepackage{ocamldoc}
-\begin{document}
-\tableofcontents
-\section{Module {\tt{Loop}}}
-\label{Loop}\index{Loop@\verb`Loop`}
-
-
-\ocamldocvspace{0.5cm}
-
-
-
-\begin{ocamldoccode}
-{\tt{module }}{\tt{A}}{\tt{ : }}\end{ocamldoccode}
-\label{Loop.A}\index{A@\verb`A`}
-
-{\tt{B}}
-
-
-
-
-
-\begin{ocamldoccode}
-{\tt{module }}{\tt{B}}{\tt{ : }}\end{ocamldoccode}
-\label{Loop.B}\index{B@\verb`B`}
-
-{\tt{A}}
-
-
-
-\end{document}
+++ /dev/null
-\documentclass[11pt]{article}
-\usepackage[latin1]{inputenc}
-\usepackage[T1]{fontenc}
-\usepackage{textcomp}
-\usepackage{fullpage}
-\usepackage{url}
-\usepackage{ocamldoc}
-\begin{document}
-\tableofcontents
-\section{Short\_description : Short global description in text mode}
-\label{Short-underscoredescription}\index{Short-underscoredescription@\verb`Short_description`}
-
-
-
-This file tests that documentation in text mode are given
-a short description in the global description of modules.
-
-
-
-
-\end{document}
+++ /dev/null
-Short global description in text mode
-
-This file tests that documentation in text mode are given
-a short description in the global description of modules.
+++ /dev/null
-
-(** Ten comments for tests *)
-
-(** {6 A first comments for title } *)
-
-(** {7 A subsection for ocamldoc *} *)
-
-(** {7 Bis } *)
-
-(** {7 Ter } *)
-
-(** {6 A new section } *)
-
-(** {7 And its subsection } *)
-
-(** {7 Encore } *)
-
-(** Encore! Encore! *)
-
-
-(**/**)
-module Silence : sig
- (** At last *)
-end
-
-(**/**)
-
-(** {7 With strange aeons } *)
-
-module End : sig end
+++ /dev/null
-\documentclass[11pt]{article}
-\usepackage[latin1]{inputenc}
-\usepackage[T1]{fontenc}
-\usepackage{textcomp}
-\usepackage{fullpage}
-\usepackage{url}
-\usepackage{ocamldoc}
-\begin{document}
-\tableofcontents
-\section{Module {\tt{Test}} : Ten comments for tests}
-\label{Test}\index{Test@\verb`Test`}
-
-
-
-
-\ocamldocvspace{0.5cm}
-
-
-
-\subsection*{A first comments for title }
-
-
-
-
-\subsubsection*{A subsection for ocamldoc *}
-
-
-
-
-\subsubsection*{Bis }
-
-
-
-
-\subsubsection*{Ter }
-
-
-
-
-\subsection*{A new section }
-
-
-
-
-\subsubsection*{And its subsection }
-
-
-
-
-\subsubsection*{Encore }
-
-
-
-
-Encore! Encore!
-
-
-
-\subsubsection*{With strange aeons }
-
-
-
-
-\begin{ocamldoccode}
-{\tt{module }}{\tt{End}}{\tt{ : }}\end{ocamldoccode}
-\label{Test.End}\index{End@\verb`End`}
-
-\begin{ocamldocsigend}
-\end{ocamldocsigend}
-
-
-
-
-\end{document}
+++ /dev/null
-(** This test is here to check the latex code generated for variants *)
-
-type s = A | B (** only B is documented here *) | C
-
-type t =
- | A
- (** doc for A *)
- | B
- (** doc for B *)
-
-(** Some documentation for u*)
-type u =
-| A (** doc for A *) | B of unit (** doc for B *)
-
-
-(** With records *)
-type w =
-| A of { x: int }
- (** doc for A *)
-| B of { y:int }
- (** doc for B *)
-
-(** With args *)
-type z =
-| A of int
- (** doc for A *)
-| B of int
- (** doc for B *)
-
-(** Gadt notation *)
-type a =
- A: a (** doc for A*)
-
-(** Lonely constructor *)
-type b =
- B (** doc for B *)
-
-type no_documentation = A | B | C
+++ /dev/null
-\documentclass[11pt]{article}
-\usepackage[latin1]{inputenc}
-\usepackage[T1]{fontenc}
-\usepackage{textcomp}
-\usepackage{fullpage}
-\usepackage{url}
-\usepackage{ocamldoc}
-\begin{document}
-\tableofcontents
-\section{Module {\tt{Variants}} : This test is here to check the latex code generated for variants}
-\label{Variants}\index{Variants@\verb`Variants`}
-
-
-
-
-\ocamldocvspace{0.5cm}
-
-
-
-\label{TYPVariants.s}\begin{ocamldoccode}
-type s =
- | A
- | B
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-only B is documented here
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- | C
-\end{ocamldoccode}
-\index{s@\verb`s`}
-
-
-
-
-\label{TYPVariants.t}\begin{ocamldoccode}
-type t =
- | A
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-doc for A
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- | B
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-doc for B
-
-
-\end{ocamldoccomment}
-\index{t@\verb`t`}
-
-
-
-
-\label{TYPVariants.u}\begin{ocamldoccode}
-type u =
- | A
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-doc for A
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- | B of unit
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-doc for B
-
-
-\end{ocamldoccomment}
-\index{u@\verb`u`}
-\begin{ocamldocdescription}
-Some documentation for u
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPVariants.w}\begin{ocamldoccode}
-type w =
- | A of {\char123} x : int ;
-{\char125}
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-doc for A
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- | B of {\char123} y : int ;
-{\char125}
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-doc for B
-
-
-\end{ocamldoccomment}
-\index{w@\verb`w`}
-\begin{ocamldocdescription}
-With records
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPVariants.z}\begin{ocamldoccode}
-type z =
- | A of int
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-doc for A
-
-
-\end{ocamldoccomment}
-\begin{ocamldoccode}
- | B of int
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-doc for B
-
-
-\end{ocamldoccomment}
-\index{z@\verb`z`}
-\begin{ocamldocdescription}
-With args
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPVariants.a}\begin{ocamldoccode}
-type a =
- | A : a
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-doc for A
-
-
-\end{ocamldoccomment}
-\index{a@\verb`a`}
-\begin{ocamldocdescription}
-Gadt notation
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPVariants.b}\begin{ocamldoccode}
-type b =
- | B
-\end{ocamldoccode}
-\begin{ocamldoccomment}
-doc for B
-
-
-\end{ocamldoccomment}
-\index{b@\verb`b`}
-\begin{ocamldocdescription}
-Lonely constructor
-
-
-\end{ocamldocdescription}
-
-
-
-
-\label{TYPVariants.no-underscoredocumentation}\begin{ocamldoccode}
-type no_documentation =
- | A
- | B
- | C
-\end{ocamldoccode}
-\index{no-underscoredocumentation@\verb`no_documentation`}
-
-
-\end{document}
+++ /dev/null
-(** Test the html rendering of ocamldoc documentation tags *)
-
-val heterological: unit
-(**
- @author yes
- @param no No description
- @param neither see no description
- @deprecated since the start of time
- @return ()
- @see "Documentation_tags.mli" Self reference
- @since Now
- @before Time not implemented
-*)
-
-val noop: unit
-(**
- @raise Not_found Never
- @raise Invalid_argument Never
-*)
+++ /dev/null
-<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
-<html>
-<head>
-<link rel="stylesheet" href="style.css" type="text/css">
-<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
-<meta name="viewport" content="width=device-width, initial-scale=1">
-<link rel="Start" href="index.html">
-<link rel="Up" href="index.html">
-<link title="Index of values" rel=Appendix href="index_values.html">
-<link title="Index of modules" rel=Appendix href="index_modules.html">
-<link title="Documentation_tags" rel="Chapter" href="Documentation_tags.html"><title>Documentation_tags</title>
-</head>
-<body>
-<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
- </div>
-<h1>Module <a href="type_Documentation_tags.html">Documentation_tags</a></h1>
-
-<pre><span id="MODULEDocumentation_tags"><span class="keyword">module</span> Documentation_tags</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Documentation_tags.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
-<div class="info-desc">
-<p>Test the html rendering of ocamldoc documentation tags</p>
-</div>
-</div>
-<hr width="100%">
-
-<pre><span id="VALheterological"><span class="keyword">val</span> heterological</span> : <code class="type">unit</code></pre><div class="info ">
-<div class="info-deprecated">
-<span class="warning">Deprecated.</span>since the start of time</div>
-<ul class="info-attributes">
-<li><b>Author(s):</b> yes</li>
-<li><b>Before Time </b> not implemented</li>
-<li><b>Since</b> Now</li>
-<li><b>Returns</b> ()</li>
-<li><b>See also</b> <i>Documentation_tags.mli</i> Self reference</li>
-</ul>
-</div>
-
-<pre><span id="VALnoop"><span class="keyword">val</span> noop</span> : <code class="type">unit</code></pre><div class="info ">
-<ul class="info-attributes">
-<li><b>Raises</b><ul><li><code>Not_found</code> Never</li>
-<li><code>Invalid_argument</code> Never</li>
-</ul></li>
-</ul>
-</div>
-</body></html>
\ No newline at end of file
+++ /dev/null
-(**
- This test focuses on the printing of documentation for inline record
- within the latex generator.
-*)
-
-
-(** A nice exception *)
-exception Simple
-
-(** An open sum type *)
-type ext = ..
-
-(** A simple record type for reference *)
-type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
- more:int list (** More documentation for r, [more : int list] *) }
-
-
-(** A sum type with one inline record *)
-type t = A of {lbl: int (** [A] field documentation *)
- ; more:int list (** More [A] field documentation *) }
-(** Constructor documentation *)
-
-(** A sum type with two inline records *)
-type s =
- | B of { a_label_for_B : int (** [B] field documentation *);
- more_label_for_B:int list (** More [B] field documentation *) }
- (** Constructor B documentation *)
- | C of { c_has_label_too: float (** [C] field documentation*);
- more_than_one: unit (** ... documentations *) }
- (** Constructor C documentation *)
-
-(** A gadt constructor *)
-type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
-(** Constructor D documentation *)
-
-exception Error of {name:string (** Error field documentation [name:string] *) }
-
-type ext +=
- | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
- (** Constructor E documentation *)
- | F of { even_more: int -> int (** Some field documentations for [F] *) }
- (** Constructor F documentation *)
- | G of { last: int -> int (** The last and least field documentation *) }
- (** Constructor G documentation *)
-(** Two new constructors for ext *)
+++ /dev/null
-<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
-<html>
-<head>
-<link rel="stylesheet" href="style.css" type="text/css">
-<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
-<meta name="viewport" content="width=device-width, initial-scale=1">
-<link rel="Start" href="index.html">
-<link rel="Up" href="index.html">
-<link title="Index of types" rel=Appendix href="index_types.html">
-<link title="Index of extensions" rel=Appendix href="index_extensions.html">
-<link title="Index of exceptions" rel=Appendix href="index_exceptions.html">
-<link title="Index of modules" rel=Appendix href="index_modules.html">
-<link title="Inline_records" rel="Chapter" href="Inline_records.html"><title>Inline_records</title>
-</head>
-<body>
-<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
- </div>
-<h1>Module <a href="type_Inline_records.html">Inline_records</a></h1>
-
-<pre><span id="MODULEInline_records"><span class="keyword">module</span> Inline_records</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Inline_records.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
-<div class="info-desc">
-<p>This test focuses on the printing of documentation for inline record
- within the latex generator.</p>
-</div>
-</div>
-<hr width="100%">
-
-<pre><span id="EXCEPTIONSimple"><span class="keyword">exception</span> Simple</span></pre>
-<div class="info ">
-<div class="info-desc">
-<p>A nice exception</p>
-</div>
-</div>
-
-<pre><span id="TYPEext"><span class="keyword">type</span> <code class="type"></code>ext</span> = ..</pre>
-<div class="info ">
-<div class="info-desc">
-<p>An open sum type</p>
-</div>
-</div>
-
-
-<pre><code><span id="TYPEr"><span class="keyword">type</span> <code class="type"></code>r</span> = {</code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTr.lbl">lbl</span> : <code class="type">int</code>;</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>Field documentation for non-inline, <code class="code">lbl : int</code></p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTr.more">more</span> : <code class="type">int list</code>;</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>More documentation for r, <code class="code">more : int list</code></p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-}
-
-<div class="info ">
-<div class="info-desc">
-<p>A simple record type for reference</p>
-</div>
-</div>
-
-
-<pre><code><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> = </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTt.A"><span class="constructor">A</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTInline_records.A.lbl">lbl</span> : <code class="type">int</code>;</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p><code class="code"><span class="constructor">A</span></code> field documentation</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTInline_records.A.more">more</span> : <code class="type">int list</code>;</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>More <code class="code"><span class="constructor">A</span></code> field documentation</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-}
-</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>Constructor documentation</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-
-<div class="info ">
-<div class="info-desc">
-<p>A sum type with one inline record</p>
-</div>
-</div>
-
-
-<pre><code><span id="TYPEs"><span class="keyword">type</span> <code class="type"></code>s</span> = </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTs.B"><span class="constructor">B</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTInline_records.B.a_label_for_B">a_label_for_B</span> : <code class="type">int</code>;</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p><code class="code"><span class="constructor">B</span></code> field documentation</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTInline_records.B.more_label_for_B">more_label_for_B</span> : <code class="type">int list</code>;</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>More <code class="code"><span class="constructor">B</span></code> field documentation</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-}
-</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>Constructor B documentation</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTs.C"><span class="constructor">C</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTInline_records.C.c_has_label_too">c_has_label_too</span> : <code class="type">float</code>;</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p><code class="code"><span class="constructor">C</span></code> field documentation</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTInline_records.C.more_than_one">more_than_one</span> : <code class="type">unit</code>;</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>... documentations</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-}
-</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>Constructor C documentation</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-
-<div class="info ">
-<div class="info-desc">
-<p>A sum type with two inline records</p>
-</div>
-</div>
-
-
-<pre><code><span id="TYPEany"><span class="keyword">type</span> <code class="type"></code>any</span> = </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTany.D"><span class="constructor">D</span></span> <span class="keyword">:</span> <code>{</code><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTInline_records.D.any">any</span> : <code class="type">'a</code>;</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p><code class="code"><span class="constructor">A</span></code> field <code class="code">any:<span class="keywordsign">'</span>a</code> for <code class="code"><span class="constructor">D</span></code> in <code class="code">any</code>.</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-}
- <span class="keyword">-></span> <code class="type"><a href="Inline_records.html#TYPEany">any</a></code></code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>Constructor D documentation</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-
-<div class="info ">
-<div class="info-desc">
-<p>A gadt constructor</p>
-</div>
-</div>
-
-
-<pre><span id="EXCEPTIONError"><span class="keyword">exception</span> Error</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTInline_records.Error.name">name</span> : <code class="type">string</code>;</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>Error field documentation <code class="code">name:string</code></p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-}
-</pre>
-<pre><code><span class="keyword">type</span> <code class="type"></code><a href="Inline_records.html#TYPEext">ext</a> += </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="EXTENSIONE">E</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTInline_records.E.yet_another_field">yet_another_field</span> : <code class="type">unit</code>;</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>Field documentation for <code class="code"><span class="constructor">E</span></code> in ext</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-}
-</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>Constructor E documentation</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="EXTENSIONF">F</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTInline_records.F.even_more">even_more</span> : <code class="type">int -> int</code>;</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>Some field documentations for <code class="code"><span class="constructor">F</span></code></p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-}
-</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>Constructor F documentation</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="EXTENSIONG">G</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTInline_records.G.last">last</span> : <code class="type">int -> int</code>;</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>The last and least field documentation</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-}
-</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>Constructor G documentation</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-
-<div class="info ">
-<div class="info-desc">
-<p>Two new constructors for ext</p>
-</div>
-</div>
-
-</body></html>
\ No newline at end of file
+++ /dev/null
-(** Check that all toplevel items are given a unique id. *)
-
-exception Ex
-type t
-val x: t
-type ext = ..
-type ext += A
-class c: object end
-class type ct= object end
-[@@@attribute]
-module M: sig end
-module type s = sig end
-
+++ /dev/null
-<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
-<html>
-<head>
-<link rel="stylesheet" href="style.css" type="text/css">
-<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
-<meta name="viewport" content="width=device-width, initial-scale=1">
-<link rel="Start" href="index.html">
-<link rel="Up" href="index.html">
-<link title="Index of types" rel=Appendix href="index_types.html">
-<link title="Index of extensions" rel=Appendix href="index_extensions.html">
-<link title="Index of exceptions" rel=Appendix href="index_exceptions.html">
-<link title="Index of values" rel=Appendix href="index_values.html">
-<link title="Index of classes" rel=Appendix href="index_classes.html">
-<link title="Index of class types" rel=Appendix href="index_class_types.html">
-<link title="Index of modules" rel=Appendix href="index_modules.html">
-<link title="Index of module types" rel=Appendix href="index_module_types.html">
-<link title="Item_ids" rel="Chapter" href="Item_ids.html"><title>Item_ids</title>
-</head>
-<body>
-<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
- </div>
-<h1>Module <a href="type_Item_ids.html">Item_ids</a></h1>
-
-<pre><span id="MODULEItem_ids"><span class="keyword">module</span> Item_ids</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Item_ids.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
-<div class="info-desc">
-<p>Check that all toplevel items are given a unique id.</p>
-</div>
-</div>
-<hr width="100%">
-
-<pre><span id="EXCEPTIONEx"><span class="keyword">exception</span> Ex</span></pre>
-
-<pre><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> </pre>
-
-
-<pre><span id="VALx"><span class="keyword">val</span> x</span> : <code class="type"><a href="Item_ids.html#TYPEt">t</a></code></pre>
-<pre><span id="TYPEext"><span class="keyword">type</span> <code class="type"></code>ext</span> = ..</pre>
-
-<pre><code><span class="keyword">type</span> <code class="type"></code><a href="Item_ids.html#TYPEext">ext</a> += </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="EXTENSIONA">A</span></code></td>
-
-</tr></table>
-
-
-
-<pre><span id="TYPEc"><span class="keyword">class</span> <a href="Item_ids.c-c.html">c</a></span> : <code class="type"></code><code class="code"><span class="keyword">object</span></code> <a href="Item_ids.c-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
-<pre><span id="TYPEct"><span class="keyword">class type</span> <a href="Item_ids.ct-c.html">ct</a></span> = <code class="code"><span class="keyword">object</span></code> <a href="Item_ids.ct-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
-<pre><span id="MODULEM"><span class="keyword">module</span> <a href="Item_ids.M.html">M</a></span>: <code class="code"><span class="keyword">sig</span></code> <a href="Item_ids.M.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
-<pre><span id="MODULETYPEs"><span class="keyword">module type</span> <a href="Item_ids.s-c.html">s</a></span> = <code class="code"><span class="keyword">sig</span></code> <a href="Item_ids.s-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre></body></html>
\ No newline at end of file
+++ /dev/null
-(**
- This file tests the encoding of linebreak inside OCaml code by the
- ocamldoc html backend.
-
- Two slightly different aspects are tested in this very file.
-
- - First, inside a "pre" tags, blanks character should not be escaped.
- For instance, the generated html code for this test fragment should not
- contain any <br> tag:
- {[
- let f x =
- let g x =
- let h x = x in
- h x in
- g x
- ]}
- See {{:http://caml.inria.fr/mantis/view.php?id=6341} MPR#6341} for more
- details or the file Linebreaks.html generated by ocamldoc from this file.
- - Second, outside of a "pre" tags, blank characters in embedded code
- should be escaped, in order to make them render in a "pre"-like fashion.
- A good example should be the files type_{i Modulename}.html generated by
- ocamldoc that should contains the signature of the module [Modulename] in
- a "code" tags.
- For instance with the following type definitions,
-*)
-
-type a = A
-type 'a b = {field:'a}
-type c = C: 'a -> c
-
-type s = ..
-type s += B
-
-val x : a
-
-module S: sig module I:sig end end
-module type s = sig end
-
-class type d = object end
-
-exception E of {inline:int}
-
-
-(** type_Linebreaks.html should contain
-
-{[
-sig
- type a = A
- type 'a b = { field : 'a; }
- type c = C : 'a -> Linebreaks.c
- type s = ..
- type s += B
- val x : Linebreaks.a
- module S : sig module I : sig end end
- module type s = sig end
- class type d = object end
- exception E of { inline : int; }
-end
-]}
-
-with <br> tags used for linebreaks.
-Another example would be [ let f x =
-x] which is rendered with a <br> linebreak inside Linebreaks.html.
-
-See {{:http://caml.inria.fr/mantis/view.php?id=7272}MPR#7272} for more
-information.
-
-*)
+++ /dev/null
-<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
-<html>
-<head>
-<link rel="stylesheet" href="style.css" type="text/css">
-<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
-<meta name="viewport" content="width=device-width, initial-scale=1">
-<link rel="Start" href="index.html">
-<link rel="Up" href="index.html">
-<link title="Index of types" rel=Appendix href="index_types.html">
-<link title="Index of extensions" rel=Appendix href="index_extensions.html">
-<link title="Index of exceptions" rel=Appendix href="index_exceptions.html">
-<link title="Index of values" rel=Appendix href="index_values.html">
-<link title="Index of class types" rel=Appendix href="index_class_types.html">
-<link title="Index of modules" rel=Appendix href="index_modules.html">
-<link title="Index of module types" rel=Appendix href="index_module_types.html">
-<link title="Linebreaks" rel="Chapter" href="Linebreaks.html"><title>Linebreaks</title>
-</head>
-<body>
-<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
- </div>
-<h1>Module <a href="type_Linebreaks.html">Linebreaks</a></h1>
-
-<pre><span id="MODULELinebreaks"><span class="keyword">module</span> Linebreaks</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
-<div class="info-desc">
-<p>This file tests the encoding of linebreak inside OCaml code by the
- ocamldoc html backend.</p>
-
-<p>Two slightly different aspects are tested in this very file.</p>
-
-<ul>
-<li>First, inside a "pre" tags, blanks character should not be escaped.
- For instance, the generated html code for this test fragment should not
- contain any <br> tag:
- <pre class="codepre"><code class="code"> <span class="keyword">let</span> f x =
- <span class="keyword">let</span> g x =
- <span class="keyword">let</span> h x = x <span class="keyword">in</span>
- h x <span class="keyword">in</span>
- g x
- </code></pre>
- See <a href="http://caml.inria.fr/mantis/view.php?id=6341"> MPR#6341</a> for more
- details or the file Linebreaks.html generated by ocamldoc from this file.</li>
-<li>Second, outside of a "pre" tags, blank characters in embedded code
- should be escaped, in order to make them render in a "pre"-like fashion.
- A good example should be the files type_<i>Modulename</i>.html generated by
- ocamldoc that should contains the signature of the module <code class="code"><span class="constructor">Modulename</span></code> in
- a "code" tags.
- For instance with the following type definitions,</li>
-</ul>
-</div>
-</div>
-<hr width="100%">
-
-<pre><code><span id="TYPEa"><span class="keyword">type</span> <code class="type"></code>a</span> = </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTa.A"><span class="constructor">A</span></span></code></td>
-
-</tr></table>
-
-
-
-<pre><code><span id="TYPEb"><span class="keyword">type</span> <code class="type">'a</code> b</span> = {</code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTb.field">field</span> : <code class="type">'a</code>;</code></td>
-
-</tr></table>
-}
-
-
-
-<pre><code><span id="TYPEc"><span class="keyword">type</span> <code class="type"></code>c</span> = </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTc.C"><span class="constructor">C</span></span> <span class="keyword">:</span> <code class="type">'a</code> <span class="keyword">-></span> <code class="type"><a href="Linebreaks.html#TYPEc">c</a></code></code></td>
-
-</tr></table>
-
-
-
-<pre><span id="TYPEs"><span class="keyword">type</span> <code class="type"></code>s</span> = ..</pre>
-
-<pre><code><span class="keyword">type</span> <code class="type"></code><a href="Linebreaks.html#TYPEs">s</a> += </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="EXTENSIONB">B</span></code></td>
-
-</tr></table>
-
-
-
-<pre><span id="VALx"><span class="keyword">val</span> x</span> : <code class="type"><a href="Linebreaks.html#TYPEa">a</a></code></pre>
-<pre><span id="MODULES"><span class="keyword">module</span> <a href="Linebreaks.S.html">S</a></span>: <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.S.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
-<pre><span id="MODULETYPEs"><span class="keyword">module type</span> <a href="Linebreaks.s-c.html">s</a></span> = <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.s-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
-<pre><span id="TYPEd"><span class="keyword">class type</span> <a href="Linebreaks.d-c.html">d</a></span> = <code class="code"><span class="keyword">object</span></code> <a href="Linebreaks.d-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
-<pre><span id="EXCEPTIONE"><span class="keyword">exception</span> E</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTLinebreaks.E.inline">inline</span> : <code class="type">int</code>;</code></td>
-
-</tr></table>
-}
-</pre>
-<p>type_Linebreaks.html should contain</p>
-
-<pre class="codepre"><code class="code"><span class="keyword">sig</span>
- <span class="keyword">type</span> a = <span class="constructor">A</span>
- <span class="keyword">type</span> <span class="keywordsign">'</span>a b = { field : <span class="keywordsign">'</span>a; }
- <span class="keyword">type</span> c = <span class="constructor">C</span> : <span class="keywordsign">'</span>a <span class="keywordsign">-></span> <span class="constructor">Linebreaks</span>.c
- <span class="keyword">type</span> s = ..
- <span class="keyword">type</span> s += <span class="constructor">B</span>
- <span class="keyword">val</span> x : <span class="constructor">Linebreaks</span>.a
- <span class="keyword">module</span> <span class="constructor">S</span> : <span class="keyword">sig</span> <span class="keyword">module</span> <span class="constructor">I</span> : <span class="keyword">sig</span> <span class="keyword">end</span> <span class="keyword">end</span>
- <span class="keyword">module</span> <span class="keyword">type</span> s = <span class="keyword">sig</span> <span class="keyword">end</span>
- <span class="keyword">class</span> <span class="keyword">type</span> d = <span class="keyword">object</span> <span class="keyword">end</span>
- <span class="keyword">exception</span> <span class="constructor">E</span> <span class="keyword">of</span> { inline : int; }
-<span class="keyword">end</span>
-</code></pre>
-<p>with <br> tags used for linebreaks.
-Another example would be <code class="code"> <span class="keyword">let</span> f x =<br>
-x</code> which is rendered with a <br> linebreak inside Linebreaks.html.</p>
-
-<p>See <a href="http://caml.inria.fr/mantis/view.php?id=7272">MPR#7272</a> for more
-information.</p>
-</body></html>
\ No newline at end of file
+++ /dev/null
-
-module rec A : sig type t end = B and B : sig type t = A.t end = A;;
-
+++ /dev/null
-<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
-<html>
-<head>
-<link rel="stylesheet" href="style.css" type="text/css">
-<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
-<meta name="viewport" content="width=device-width, initial-scale=1">
-<link rel="Start" href="index.html">
-<link rel="Up" href="index.html">
-<link title="Index of modules" rel=Appendix href="index_modules.html">
-<link title="Loop" rel="Chapter" href="Loop.html"><title>Loop</title>
-</head>
-<body>
-<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
- </div>
-<h1>Module <a href="type_Loop.html">Loop</a></h1>
-
-<pre><span id="MODULELoop"><span class="keyword">module</span> Loop</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Loop.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><hr width="100%">
-
-<pre><span id="MODULEA"><span class="keyword">module</span> <a href="Loop.A.html">A</a></span>: <code class="type"><a href="Loop.B.html">B</a></code></pre>
-<pre><span id="MODULEB"><span class="keyword">module</span> <a href="Loop.B.html">B</a></span>: <code class="type"><a href="Loop.A.html">A</a></code></pre></body></html>
\ No newline at end of file
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-COMPFLAGS=-I $(OTOPDIR)/ocamldoc
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
-DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)\
- -latextitle "6,subsection*" \
- -latextitle "7,subsubsection*" \
- -latex-type-prefix "TYP" \
- -latex-module-prefix "" \
- -latex-module-type-prefix "" \
- -latex-value-prefix ""
-
-.PHONY: default
-default:
- @if ! $(SUPPORTS_SHARED_LIBRARIES); then \
- echo 'skipped (shared libraries not available)'; \
- else \
- $(SET_LD_PATH) $(MAKE) run; \
- fi
-
-.PHONY: run
-run: *.mli *.ml
-# Note that we strip both .ml and .mli extensions
- @for file in *.ml *.mli; do \
- printf " ... testing '$$file'"; \
- F="`basename $$file .mli`"; \
- F="`basename $$F .ml`"; \
- $(OCAMLDOC) $(DOCFLAGS) -colorize-code -hide-warnings -html $ \
- -o index $$file; \
- cp $$F.html $$F.result; \
- $(DIFF) $$F.reference $$F.result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done;\
-# For linebreaks.mli, we also compare type_Linebreaks.html and not only
-# the main html file
- @cp type_Linebreaks.html type_Linebreaks.result;\
- printf " ... testing 'type_Linebreak.html'";\
- $(DIFF) type_Linebreaks.reference type_Linebreaks.result\
- && echo " => passed" || echo " => failed"
-
-.PHONY: promote
-promote: defaultpromote
-
-.PHONY: clean
-clean: defaultclean
- @rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux
-
-include $(BASEDIR)/makefiles/Makefile.common
+++ /dev/null
-module M = Set.Make(struct
- type t = int
- let compare = compare
-end)
+++ /dev/null
-<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
-<html>
-<head>
-<link rel="stylesheet" href="style.css" type="text/css">
-<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
-<meta name="viewport" content="width=device-width, initial-scale=1">
-<link rel="Start" href="index.html">
-<link rel="Up" href="index.html">
-<link title="Index of modules" rel=Appendix href="index_modules.html">
-<link title="Module_whitespace" rel="Chapter" href="Module_whitespace.html"><title>Module_whitespace</title>
-</head>
-<body>
-<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
- </div>
-<h1>Module <a href="type_Module_whitespace.html">Module_whitespace</a></h1>
-
-<pre><span id="MODULEModule_whitespace"><span class="keyword">module</span> Module_whitespace</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Module_whitespace.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><hr width="100%">
-
-<pre><span id="MODULEM"><span class="keyword">module</span> <a href="Module_whitespace.M.html">M</a></span>: <code class="type">Set.Make</code><code class="code">(</code><code class="code"><span class="keyword">sig</span></code></pre><div class="sig_block">
-<pre><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> = <code class="type">int</code> </pre>
-
-
-<pre><span id="VALcompare"><span class="keyword">val</span> compare</span> : <code class="type">'a -> 'a -> int</code></pre></div>
-<pre><code class="code"><span class="keyword">end</span></code><code class="code">)</code></pre></body></html>
\ No newline at end of file
+++ /dev/null
-
-open String
-
-(** This is a documentation comment for [x], not a module preamble. *)
-val x: unit
+++ /dev/null
-<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
-<html>
-<head>
-<link rel="stylesheet" href="style.css" type="text/css">
-<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
-<meta name="viewport" content="width=device-width, initial-scale=1">
-<link rel="Start" href="index.html">
-<link rel="Up" href="index.html">
-<link title="Index of values" rel=Appendix href="index_values.html">
-<link title="Index of modules" rel=Appendix href="index_modules.html">
-<link title="No_preamble" rel="Chapter" href="No_preamble.html"><title>No_preamble</title>
-</head>
-<body>
-<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
- </div>
-<h1>Module <a href="type_No_preamble.html">No_preamble</a></h1>
-
-<pre><span id="MODULENo_preamble"><span class="keyword">module</span> No_preamble</span>: <code class="code"><span class="keyword">sig</span></code> <a href="No_preamble.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><hr width="100%">
-
-<pre><span id="VALx"><span class="keyword">val</span> x</span> : <code class="type">unit</code></pre><div class="info ">
-<div class="info-desc">
-<p>This is a documentation comment for <code class="code">x</code>, not a module preamble.</p>
-</div>
-</div>
-</body></html>
\ No newline at end of file
+++ /dev/null
-(** This file tests the generation of paragraph within module comments.
-
-
- At least three points should be exercised in this tests
-
- - First, all text should be tagged
- - Second, no paragraph should contain only spaces characters
- - Third, the mixing of different text style should not create
- invalid p tags
-
-
- See also {{: http://caml.inria.fr/mantis/view.php?id=7352} MPR:7352},
- {{: http://caml.inria.fr/mantis/view.php?id=7353} MPR:7353}
-
- {2:here Testing non-text elements }
-
- [code x ] {i should } be inside a p.
-
-
- {e But} {b not}
- {[
- let complex_code = ()
- ]}
- here.
-
- + An enumerated list first element
- + second element
-
- {L Alignement test: left}
- {R Right}
- {C Center}
-
-
- Other complex text{_ in subscript }{^ and superscript}
- {V Verbatim V}
-
- There is also {%html: html specific %} elements.
-
- @author: Florian Angeletti
- @version: 1
-*)
-
-(** *)
-
-type t
-(**
- And cross-reference {! t}.
- {!modules: Paragraph}
- {!indexlist}
-*)
+++ /dev/null
-<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
-<html>
-<head>
-<link rel="stylesheet" href="style.css" type="text/css">
-<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
-<meta name="viewport" content="width=device-width, initial-scale=1">
-<link rel="Start" href="index.html">
-<link rel="Up" href="index.html">
-<link title="Index of types" rel=Appendix href="index_types.html">
-<link title="Index of modules" rel=Appendix href="index_modules.html">
-<link title="Paragraph" rel="Chapter" href="Paragraph.html"><title>Paragraph</title>
-</head>
-<body>
-<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
- </div>
-<h1>Module <a href="type_Paragraph.html">Paragraph</a></h1>
-
-<pre><span id="MODULEParagraph"><span class="keyword">module</span> Paragraph</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Paragraph.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
-<div class="info-desc">
-<p>This file tests the generation of paragraph within module comments.</p>
-
-<p>At least three points should be exercised in this tests</p>
-
-<ul>
-<li>First, all text should be tagged</li>
-<li>Second, no paragraph should contain only spaces characters</li>
-<li>Third, the mixing of different text style should not create
- invalid p tags</li>
-</ul>
-<p>See also <a href=" http://caml.inria.fr/mantis/view.php?id=7352"> MPR:7352</a>,
- <a href=" http://caml.inria.fr/mantis/view.php?id=7353"> MPR:7353</a></p>
-
-<h3 id="here">Testing non-text elements </h3>
-<p><code class="code">code x </code> <i>should </i> be inside a p.</p>
-
-<p><em>But</em> <b>not</b></p>
-<pre class="codepre"><code class="code"> <span class="keyword">let</span> complex_code = ()
- </code></pre><p>here.</p>
-
-<OL>
-<li>An enumerated list first element</li>
-<li>second element</li>
-</OL>
-<div align=left>Alignement test: left</div><div align=right>Right</div><center>Center</center>
-<p>Other complex text<sub class="subscript">in subscript </sub><sup class="superscript">and superscript</sup></p>
-
-<p>There is also html specific elements.</p>
-</div>
-<ul class="info-attributes">
-<li><b>Author(s):</b> : Florian Angeletti</li>
-<li><b>Version:</b> : 1</li>
-</ul>
-</div>
-<hr width="100%">
-
-<pre><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> </pre>
-<div class="info ">
-<div class="info-desc">
-<p>And cross-reference <a href="Paragraph.html#TYPEt"><code class="code"><span class="constructor">Paragraph</span>.t</code></a>.
-
-<table class="indextable module-list">
-<tr><td class="module"><a href="Paragraph.html">Paragraph</a></td><td><div class="info">
-<p>This file tests the generation of paragraph within module comments.</p>
-
-</div>
-</td></tr>
-</table></p>
-<ul class="indexlist">
-<li><a href="index_types.html">Index of types</a></li>
-<li><a href="index_modules.html">Index of modules</a></li>
-</ul>
-</div>
-</div>
-
-</body></html>
\ No newline at end of file
+++ /dev/null
-(** This test is here to check the latex code generated for variants *)
-
-type s = A | B (** only B is documented here *) | C
-
-type t =
- | A
- (** doc for A.
- {[0]}
- With three paragraphs.
- {[1]}
- To check styling
- *)
- | B
- (** doc for B *)
-
-(** Some documentation for u*)
-type u =
-| A (** doc for A *) | B of unit (** doc for B *)
-
-
-(** With records *)
-type w =
-| A of { x: int }
- (** doc for A *)
-| B of { y:int }
- (** doc for B *)
-
-(** With args *)
-type z =
-| A of int
- (** doc for A *)
-| B of int
- (** doc for B *)
-
-(** Gadt notation *)
-type a =
- A: a (** doc for A*)
-
-(** Lonely constructor *)
-type b =
- B (** doc for B *)
-
-type no_documentation = A | B | C
+++ /dev/null
-<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
-<html>
-<head>
-<link rel="stylesheet" href="style.css" type="text/css">
-<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
-<meta name="viewport" content="width=device-width, initial-scale=1">
-<link rel="Start" href="index.html">
-<link rel="Up" href="index.html">
-<link title="Index of types" rel=Appendix href="index_types.html">
-<link title="Index of modules" rel=Appendix href="index_modules.html">
-<link title="Variants" rel="Chapter" href="Variants.html"><title>Variants</title>
-</head>
-<body>
-<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
- </div>
-<h1>Module <a href="type_Variants.html">Variants</a></h1>
-
-<pre><span id="MODULEVariants"><span class="keyword">module</span> Variants</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Variants.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
-<div class="info-desc">
-<p>This test is here to check the latex code generated for variants</p>
-</div>
-</div>
-<hr width="100%">
-
-<pre><code><span id="TYPEs"><span class="keyword">type</span> <code class="type"></code>s</span> = </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTs.A"><span class="constructor">A</span></span></code></td>
-
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTs.B"><span class="constructor">B</span></span></code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>only B is documented here</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTs.C"><span class="constructor">C</span></span></code></td>
-
-</tr></table>
-
-
-
-<pre><code><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> = </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTt.A"><span class="constructor">A</span></span></code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>doc for A.</p>
-<pre class="codepre"><code class="code">0</code></pre><p>With three paragraphs.</p>
-<pre class="codepre"><code class="code">1</code></pre><p>To check styling</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTt.B"><span class="constructor">B</span></span></code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>doc for B</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-
-
-
-<pre><code><span id="TYPEu"><span class="keyword">type</span> <code class="type"></code>u</span> = </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTu.A"><span class="constructor">A</span></span></code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>doc for A</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTu.B"><span class="constructor">B</span></span> <span class="keyword">of</span> <code class="type">unit</code></code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>doc for B</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-
-<div class="info ">
-<div class="info-desc">
-<p>Some documentation for u</p>
-</div>
-</div>
-
-
-<pre><code><span id="TYPEw"><span class="keyword">type</span> <code class="type"></code>w</span> = </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTw.A"><span class="constructor">A</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTVariants.A.x">x</span> : <code class="type">int</code>;</code></td>
-
-</tr></table>
-}
-</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>doc for A</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTw.B"><span class="constructor">B</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code> </code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTVariants.B.y">y</span> : <code class="type">int</code>;</code></td>
-
-</tr></table>
-}
-</code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>doc for B</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-
-<div class="info ">
-<div class="info-desc">
-<p>With records</p>
-</div>
-</div>
-
-
-<pre><code><span id="TYPEz"><span class="keyword">type</span> <code class="type"></code>z</span> = </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTz.A"><span class="constructor">A</span></span> <span class="keyword">of</span> <code class="type">int</code></code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>doc for A</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTz.B"><span class="constructor">B</span></span> <span class="keyword">of</span> <code class="type">int</code></code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>doc for B</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-
-<div class="info ">
-<div class="info-desc">
-<p>With args</p>
-</div>
-</div>
-
-
-<pre><code><span id="TYPEa"><span class="keyword">type</span> <code class="type"></code>a</span> = </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTa.A"><span class="constructor">A</span></span> <span class="keyword">:</span> <code class="type"><a href="Variants.html#TYPEa">a</a></code></code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>doc for A</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-
-<div class="info ">
-<div class="info-desc">
-<p>Gadt notation</p>
-</div>
-</div>
-
-
-<pre><code><span id="TYPEb"><span class="keyword">type</span> <code class="type"></code>b</span> = </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTb.B"><span class="constructor">B</span></span></code></td>
-<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<div class="info-desc">
-<p>doc for B</p>
-</div>
-</div>
-</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
-</tr></table>
-
-<div class="info ">
-<div class="info-desc">
-<p>Lonely constructor</p>
-</div>
-</div>
-
-
-<pre><code><span id="TYPEno_documentation"><span class="keyword">type</span> <code class="type"></code>no_documentation</span> = </code></pre><table class="typetable">
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTno_documentation.A"><span class="constructor">A</span></span></code></td>
-
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTno_documentation.B"><span class="constructor">B</span></span></code></td>
-
-</tr>
-<tr>
-<td align="left" valign="top" >
-<code><span class="keyword">|</span></code></td>
-<td align="left" valign="top" >
-<code><span id="TYPEELTno_documentation.C"><span class="constructor">C</span></span></code></td>
-
-</tr></table>
-
-
-</body></html>
\ No newline at end of file
+++ /dev/null
-<html><head>
-<link rel="stylesheet" href="style.css" type="text/css">
-<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
-<meta name="viewport" content="width=device-width, initial-scale=1">
-<link rel="Start" href="index.html">
-<link title="Index of types" rel=Appendix href="index_types.html">
-<link title="Index of extensions" rel=Appendix href="index_extensions.html">
-<link title="Index of exceptions" rel=Appendix href="index_exceptions.html">
-<link title="Index of values" rel=Appendix href="index_values.html">
-<link title="Index of class types" rel=Appendix href="index_class_types.html">
-<link title="Index of modules" rel=Appendix href="index_modules.html">
-<link title="Index of module types" rel=Appendix href="index_module_types.html">
-<link title="Linebreaks" rel="Chapter" href="Linebreaks.html"><title>Linebreaks</title>
-</head>
-<body>
-<code class="code"><span class="keyword">sig</span><br>
- <span class="keyword">type</span> a = <span class="constructor">A</span><br>
- <span class="keyword">type</span> <span class="keywordsign">'</span>a b = { field : <span class="keywordsign">'</span>a; }<br>
- <span class="keyword">type</span> c = <span class="constructor">C</span> : <span class="keywordsign">'</span>a <span class="keywordsign">-></span> <span class="constructor">Linebreaks</span>.c<br>
- <span class="keyword">type</span> s = ..<br>
- <span class="keyword">type</span> s += <span class="constructor">B</span><br>
- <span class="keyword">val</span> x : <span class="constructor">Linebreaks</span>.a<br>
- <span class="keyword">module</span> <span class="constructor">S</span> : <span class="keyword">sig</span> <span class="keyword">module</span> <span class="constructor">I</span> : <span class="keyword">sig</span> <span class="keyword">end</span> <span class="keyword">end</span><br>
- <span class="keyword">module</span> <span class="keyword">type</span> s = <span class="keyword">sig</span> <span class="keyword">end</span><br>
- <span class="keyword">class</span> <span class="keyword">type</span> d = <span class="keyword">object</span> <span class="keyword">end</span><br>
- <span class="keyword">exception</span> <span class="constructor">E</span> <span class="keyword">of</span> { inline : int; }<br>
-<span class="keyword">end</span></code></body></html>
\ No newline at end of file
+++ /dev/null
-(**
- This test focuses on the printing of documentation for inline record
- within the latex generator.
-*)
-
-
-(** A nice exception *)
-exception Simple
-
-(** An open sum type *)
-type ext = ..
-
-(** A simple record type for reference *)
-type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
- more:int list (** More documentation for r, [more : int list] *) }
-
-
-(** A sum type with one inline record *)
-type t = A of {lbl: int (** [A] field documentation *)
- ; more:int list (** More [A] field documentation *) }
-(** Constructor documentation *)
-
-(** A sum type with two inline records *)
-type s =
- | B of { a_label_for_B : int (** [B] field documentation *);
- more_label_for_B:int list (** More [B] field documentation *) }
- (** Constructor B documentation *)
- | C of { c_has_label_too: float (** [C] field documentation*);
- more_than_one: unit (** ... documentations *) }
- (** Constructor C documentation *)
-
-(** A gadt constructor *)
-type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
-(** Constructor D documentation *)
-
-exception Error of {name:string (** Error field documentation [name:string] *) }
-
-type ext +=
- | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
- (** Constructor E documentation *)
- | F of { even_more: int -> int (** Some field documentations for [F] *) }
- (** Constructor F documentation *)
- | G of { last: int -> int (** The last and least field documentation *) }
- (** Constructor G documentation *)
-(** Two new constructors for ext *)
+++ /dev/null
-.SH NAME
-Inline_records \- This test focuses on the printing of documentation for inline record within the latex generator.
-.SH Module
-Module Inline_records
-.SH Documentation
-.sp
-Module
-.BI "Inline_records"
- :
-.B sig end
-
-.sp
-This test focuses on the printing of documentation for inline record
-within the latex generator\&.
-
-.sp
-
-.sp
-.sp
-
-.I exception Simple
-
-.sp
-A nice exception
-
-.sp
-.I type ext
-= ..
-
-.sp
-An open sum type
-
-.sp
-.I type r
-= {
- lbl :
-.B int
-; (* Field documentation for non\-inline,
-.B lbl : int
-
- *)
- more :
-.B int list
-; (* More documentation for r,
-.B more : int list
-
- *)
- }
-
-.sp
-A simple record type for reference
-
-.sp
-.I type t
-=
- | A
-.B of {
- lbl :
-.B int
-; (*
-.B A
-field documentation
- *)
- more :
-.B int list
-; (* More
-.B A
-field documentation
- *)
- }
-.I " "
- (* Constructor documentation
- *)
-
-.sp
-A sum type with one inline record
-
-.sp
-.I type s
-=
- | B
-.B of {
- a_label_for_B :
-.B int
-; (*
-.B B
-field documentation
- *)
- more_label_for_B :
-.B int list
-; (* More
-.B B
-field documentation
- *)
- }
-.I " "
- (* Constructor B documentation
- *)
- | C
-.B of {
- c_has_label_too :
-.B float
-; (*
-.B C
-field documentation
- *)
- more_than_one :
-.B unit
-; (* \&.\&.\&. documentations
- *)
- }
-.I " "
- (* Constructor C documentation
- *)
-
-.sp
-A sum type with two inline records
-
-.sp
-.I type any
-=
- | D
-.B of {
- any :
-.B 'a
-; (*
-.B A
-field
-.B any:\&'a
-for
-.B D
-in
-.B any
-\&.
- *)
- }
-.B ->
-.B any
-.I " "
- (* Constructor D documentation
- *)
-
-.sp
-A gadt constructor
-
-.sp
-
-.I exception Error
-.B of {
- name :
-.B string
-; (* Error field documentation
-.B name:string
-
- *)
- }
-
-.sp
-
-.sp
-.I type ext
-+=
- | E
-.B of {
- yet_another_field :
-.B unit
-; (* Field documentation for
-.B E
-in ext
- *)
- }
-.I " "
-(* Constructor E documentation
- *)
- | F
-.B of {
- even_more :
-.B int -> int
-; (* Some field documentations for
-.B F
-
- *)
- }
-.I " "
-(* Constructor F documentation
- *)
- | G
-.B of {
- last :
-.B int -> int
-; (* The last and least field documentation
- *)
- }
-.I " "
-(* Constructor G documentation
- *)
-
-.sp
-Two new constructors for ext
-
-.sp
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-COMPFLAGS=-I $(OTOPDIR)/ocamldoc
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
-DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)\
- -latextitle "6,subsection*" \
- -latextitle "7,subsubsection*" \
- -latex-type-prefix "TYP" \
- -latex-module-prefix "" \
- -latex-module-type-prefix "" \
- -latex-value-prefix ""
-
-.PHONY: default
-default:
- @if ! $(SUPPORTS_SHARED_LIBRARIES); then \
- echo 'skipped (shared libraries not available)'; \
- else \
- $(SET_LD_PATH) $(MAKE) run; \
- fi
-
-.PHONY: run
-run: *.mli
- @for file in *.mli; do \
- printf " ... testing '$$file'"; \
- F="`basename $$file .mli`"; \
- $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -man $ \
- -o index $$file; \
- tail -n +2 $$F.3o > $$F.result; \
- $(DIFF) $$F.reference $$F.result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done
-
-.PHONY: promote
-promote: defaultpromote
-
-.PHONY: clean
-clean: defaultclean
- @rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux *.3o
-
-include $(BASEDIR)/makefiles/Makefile.common
+++ /dev/null
-BASEDIR=../..
-COMPFLAGS=-I $(OTOPDIR)/ocamldoc
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
-DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)
-
-SRC= main.ml alias.ml inner.ml
-ODOCS=$(SRC:%.ml=%.odoc)
-
-.PHONY: default
-default:
- @if ! $(SUPPORTS_SHARED_LIBRARIES); then \
- echo 'skipped (shared libraries not available)'; \
- else \
- $(SET_LD_PATH) $(MAKE) doc; \
- fi
-
-.PHONY: doc
-doc: $(ODOCS)
- @printf " ... testing ocamldoc '-open' option";\
- $(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
- -load alias.odoc -load inner.odoc \
- -load main.odoc -latex -o doc.result ;\
- $(DIFF) doc.result doc.reference > /dev/null \
- && echo " => passed" || echo " => failed";
-
-inner.odoc: inner.ml
- @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
- -dump inner.odoc inner.ml
-
-alias.odoc: inner.cmi alias.ml
- @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
- -dump alias.odoc alias.ml
-
-main.odoc: alias.cmi main.ml
- @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
- -open Alias.Container -open Aliased_inner -dump main.odoc main.ml
-
-alias.cmi:inner.cmi
-
-.PHONY: promote
-promote: defaultpromote
-
-.PHONY: clean
-clean: defaultclean
- @rm -f *.odoc *.toc *.sty *.aux *.log *.result
-
-include $(BASEDIR)/makefiles/Makefile.common
+++ /dev/null
-\documentclass[11pt]{article}
-\usepackage[latin1]{inputenc}
-\usepackage[T1]{fontenc}
-\usepackage{textcomp}
-\usepackage{fullpage}
-\usepackage{url}
-\usepackage{ocamldoc}
-\begin{document}
-\tableofcontents
-\section{Module {\tt{Alias}}}
-\label{module:Alias}\index{Alias@\verb`Alias`}
-
-
-\ocamldocvspace{0.5cm}
-
-
-
-\begin{ocamldoccode}
-{\tt{module }}{\tt{Container}}{\tt{ : }}\end{ocamldoccode}
-\label{module:Alias.Container}\index{Container@\verb`Container`}
-
-\begin{ocamldocsigend}
-
-
-\begin{ocamldoccode}
-{\tt{module }}{\tt{Aliased\_inner}}{\tt{ : }}\end{ocamldoccode}
-\label{module:Alias.Container.Aliased-underscoreinner}\index{Aliased-underscoreinner@\verb`Aliased_inner`}
-{\tt{Inner}}
-
-\end{ocamldocsigend}
-
-
-
-
-\section{Module {\tt{Inner}}}
-\label{module:Inner}\index{Inner@\verb`Inner`}
-
-
-\ocamldocvspace{0.5cm}
-
-
-
-\label{type:Inner.a}\begin{ocamldoccode}
-type a = int
-\end{ocamldoccode}
-\index{a@\verb`a`}
-
-
-\section{Module {\tt{Main}} : Documentation test}
-\label{module:Main}\index{Main@\verb`Main`}
-
-
-
-
-\ocamldocvspace{0.5cm}
-
-
-
-\label{type:Main.t}\begin{ocamldoccode}
-type t = Alias.Container.Aliased_inner.a
-\end{ocamldoccode}
-\index{t@\verb`t`}
-\begin{ocamldocdescription}
-Alias to type Inner.a
-
-
-\end{ocamldocdescription}
-
-
-\end{document}
--- /dev/null
+\documentclass[11pt]{article}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{textcomp}
+\usepackage{fullpage}
+\usepackage{url}
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Alias}}}
+\label{module:Alias}\index{Alias@\verb`Alias`}
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{Container}}{\tt{ : }}\end{ocamldoccode}
+\label{module:Alias.Container}\index{Container@\verb`Container`}
+
+\begin{ocamldocsigend}
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{Aliased\_inner}}{\tt{ : }}\end{ocamldoccode}
+\label{module:Alias.Container.Aliased-underscoreinner}\index{Aliased-underscoreinner@\verb`Aliased_inner`}
+{\tt{Inner}}
+
+\end{ocamldocsigend}
+
+
+
+
+\section{Module {\tt{Inner}}}
+\label{module:Inner}\index{Inner@\verb`Inner`}
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{type:Inner.a}\begin{ocamldoccode}
+type a = int
+\end{ocamldoccode}
+\index{a@\verb`a`}
+
+
+\section{Module {\tt{Main}} : Documentation test}
+\label{module:Main}\index{Main@\verb`Main`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{type:Main.t}\begin{ocamldoccode}
+type t = Alias.Container.Aliased_inner.a
+\end{ocamldoccode}
+\index{t@\verb`t`}
+\begin{ocamldocdescription}
+Alias to type Inner.a
+
+
+\end{ocamldocdescription}
+
+
+\end{document}
+(* TEST
+ modules = "inner.ml alias.ml"
+ * ocamldoc
+ ocamldoc_backend="latex"
+ ocamldoc_flags=" -open Alias.Container -open Aliased_inner "
+*)
(** Documentation test *)
--- /dev/null
+Warning: Module or module type Inner not found
+Warning: Module or module type Inner not found
+Warning: Module or module type Inner not found
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of values" rel=Appendix href="index_values.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Documentation_tags" rel="Chapter" href="Documentation_tags.html"><title>Documentation_tags</title>
+</head>
+<body>
+<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
+ </div>
+<h1>Module <a href="type_Documentation_tags.html">Documentation_tags</a></h1>
+
+<pre><span id="MODULEDocumentation_tags"><span class="keyword">module</span> Documentation_tags</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Documentation_tags.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+<div class="info-desc">
+<p>Test the html rendering of ocamldoc documentation tags</p>
+</div>
+</div>
+<hr width="100%">
+
+<pre><span id="VALheterological"><span class="keyword">val</span> heterological</span> : <code class="type">unit</code></pre><div class="info ">
+<div class="info-deprecated">
+<span class="warning">Deprecated.</span>since the start of time</div>
+<ul class="info-attributes">
+<li><b>Author(s):</b> yes</li>
+<li><b>Before Time </b> not implemented</li>
+<li><b>Since</b> Now</li>
+<li><b>Returns</b> ()</li>
+<li><b>See also</b> <i>Documentation_tags.mli</i> Self reference</li>
+</ul>
+</div>
+
+<pre><span id="VALnoop"><span class="keyword">val</span> noop</span> : <code class="type">unit</code></pre><div class="info ">
+<ul class="info-attributes">
+<li><b>Raises</b><ul><li><code>Not_found</code> Never</li>
+<li><code>Invalid_argument</code> Never</li>
+</ul></li>
+</ul>
+</div>
+</body></html>
--- /dev/null
+(* TEST
+ * ocamldoc with html
+*)
+
+(** Test the html rendering of ocamldoc documentation tags *)
+
+val heterological: unit
+(**
+ @author yes
+ @param no No description
+ @param neither see no description
+ @deprecated since the start of time
+ @return ()
+ @see "Documentation_tags.mli" Self reference
+ @since Now
+ @before Time not implemented
+*)
+
+val noop: unit
+(**
+ @raise Not_found Never
+ @raise Invalid_argument Never
+*)
--- /dev/null
+\documentclass[11pt]{article}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{textcomp}
+\usepackage{fullpage}
+\usepackage{url}
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Extensible\_variant}} : Testing display of extensible variant types and exceptions.}
+\label{Extensible-underscorevariant}\index{Extensible-underscorevariant@\verb`Extensible_variant`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+Also check reference for {\tt{Extensible\_variant.M.A}}[\ref{extension:Extensible-underscorevariant.M.A}], {\tt{Extensible\_variant.M.B}}[\ref{extension:Extensible-underscorevariant.M.B}], {\tt{Extensible\_variant.M.C}}[\ref{extension:Extensible-underscorevariant.M.C}] and {\tt{Extensible\_variant.E}}[\ref{exception:Extensible-underscorevariant.E}]
+
+
+
+\label{TYPExtensible-underscorevariant.e}\begin{ocamldoccode}
+type e = ..
+\end{ocamldoccode}
+\index{e@\verb`e`}
+\begin{ocamldocdescription}
+Extensible type
+
+
+\end{ocamldocdescription}
+
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{M}}{\tt{ : }}\end{ocamldoccode}
+\label{Extensible-underscorevariant.M}\index{M@\verb`M`}
+
+\begin{ocamldocsigend}
+
+
+\begin{ocamldoccode}
+type e +=
+\end{ocamldoccode}
+\label{extension:Extensible-underscorevariant.M.A}\begin{ocamldoccode}
+ | A
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+A doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.M.B}\begin{ocamldoccode}
+ | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+B doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.M.C}\begin{ocamldoccode}
+ | C
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+C doc
+
+
+\end{ocamldoccomment}
+\end{ocamldocsigend}
+
+
+
+
+
+
+\begin{ocamldoccode}
+{\tt{module type }}{\tt{MT}}{\tt{ = }}\end{ocamldoccode}
+\label{Extensible-underscorevariant.MT}\index{MT@\verb`MT`}
+
+\begin{ocamldocsigend}
+
+
+\begin{ocamldoccode}
+type e +=
+\end{ocamldoccode}
+\label{extension:Extensible-underscorevariant.MT.A}\begin{ocamldoccode}
+ | A
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+A doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.MT.B}\begin{ocamldoccode}
+ | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+B doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.MT.C}\begin{ocamldoccode}
+ | C
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+C doc
+
+
+\end{ocamldoccomment}
+\end{ocamldocsigend}
+
+
+
+
+
+
+\label{exception:Extensible-underscorevariant.E}\begin{ocamldoccode}
+exception E
+\end{ocamldoccode}
+\index{E@\verb`E`}
+
+
+\end{document}
--- /dev/null
+(* TEST
+ * ocamldoc with latex
+*)
+
+(** Testing display of extensible variant types and exceptions.
+
+ @test_types_display
+ *)
+
+(** Also check reference for {!M.A}, {!M.B}, {!M.C} and {!E} *)
+
+(** Extensible type *)
+type e = ..
+
+module M = struct
+ type e +=
+ | A (** A doc *)
+ | B (** B doc *)
+ | C (** C doc *)
+end
+
+module type MT = sig
+ type e +=
+ | A (** A doc *)
+ | B (** B doc *)
+ | C (** C doc *)
+end
+
+exception E
--- /dev/null
+Warning: Tag @test_types_display not handled by this generator
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of types" rel=Appendix href="index_types.html">
+<link title="Index of extensions" rel=Appendix href="index_extensions.html">
+<link title="Index of exceptions" rel=Appendix href="index_exceptions.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Inline_records" rel="Chapter" href="Inline_records.html"><title>Inline_records</title>
+</head>
+<body>
+<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
+ </div>
+<h1>Module <a href="type_Inline_records.html">Inline_records</a></h1>
+
+<pre><span id="MODULEInline_records"><span class="keyword">module</span> Inline_records</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Inline_records.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+<div class="info-desc">
+<p>This test focuses on the printing of documentation for inline record
+ within the latex generator.</p>
+</div>
+</div>
+<hr width="100%">
+
+<pre><span id="EXCEPTIONSimple"><span class="keyword">exception</span> Simple</span></pre>
+<div class="info ">
+<div class="info-desc">
+<p>A nice exception</p>
+</div>
+</div>
+
+<pre><span id="EXCEPTIONLess"><span class="keyword">exception</span> Less</span> <span class="keyword">of</span> <code class="type">int</code></pre>
+<div class="info ">
+<div class="info-desc">
+<p>A less simple exception</p>
+</div>
+</div>
+
+<pre><span id="TYPEext"><span class="keyword">type</span> <code class="type"></code>ext</span> = ..</pre>
+<div class="info ">
+<div class="info-desc">
+<p>An open sum type</p>
+</div>
+</div>
+
+
+<pre><code><span id="TYPEr"><span class="keyword">type</span> <code class="type"></code>r</span> = {</code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTr.lbl">lbl</span> : <code class="type">int</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>Field documentation for non-inline, <code class="code">lbl : int</code></p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTr.more">more</span> : <code class="type">int list</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>More documentation for r, <code class="code">more : int list</code></p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+
+<div class="info ">
+<div class="info-desc">
+<p>A simple record type for reference</p>
+</div>
+</div>
+
+
+<pre><code><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTt.A"><span class="constructor">A</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.A.lbl">lbl</span> : <code class="type">int</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p><code class="code"><span class="constructor">A</span></code> field documentation</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.A.more">more</span> : <code class="type">int list</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>More <code class="code"><span class="constructor">A</span></code> field documentation</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>Constructor documentation</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+<div class="info-desc">
+<p>A sum type with one inline record</p>
+</div>
+</div>
+
+
+<pre><code><span id="TYPEs"><span class="keyword">type</span> <code class="type"></code>s</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTs.B"><span class="constructor">B</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.B.a_label_for_B">a_label_for_B</span> : <code class="type">int</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p><code class="code"><span class="constructor">B</span></code> field documentation</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.B.more_label_for_B">more_label_for_B</span> : <code class="type">int list</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>More <code class="code"><span class="constructor">B</span></code> field documentation</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>Constructor B documentation</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTs.C"><span class="constructor">C</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.C.c_has_label_too">c_has_label_too</span> : <code class="type">float</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p><code class="code"><span class="constructor">C</span></code> field documentation</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.C.more_than_one">more_than_one</span> : <code class="type">unit</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>... documentations</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>Constructor C documentation</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+<div class="info-desc">
+<p>A sum type with two inline records</p>
+</div>
+</div>
+
+
+<pre><code><span id="TYPEany"><span class="keyword">type</span> <code class="type"></code>any</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTany.D"><span class="constructor">D</span></span> <span class="keyword">:</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.D.any">any</span> : <code class="type">'a</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p><code class="code"><span class="constructor">A</span></code> field <code class="code">any:<span class="keywordsign">'</span>a</code> for <code class="code"><span class="constructor">D</span></code> in <code class="code">any</code>.</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+ <span class="keyword">-></span> <code class="type"><a href="Inline_records.html#TYPEany">any</a></code></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>Constructor D documentation</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+<div class="info-desc">
+<p>A gadt constructor</p>
+</div>
+</div>
+
+
+<pre><span id="EXCEPTIONError"><span class="keyword">exception</span> Error</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.Error.name">name</span> : <code class="type">string</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>Error field documentation <code class="code">name:string</code></p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+</pre>
+<pre><code><span class="keyword">type</span> <code class="type"></code><a href="Inline_records.html#TYPEext">ext</a> += </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="EXTENSIONE">E</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.E.yet_another_field">yet_another_field</span> : <code class="type">unit</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>Field documentation for <code class="code"><span class="constructor">E</span></code> in ext</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>Constructor E documentation</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="EXTENSIONF">F</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.F.even_more">even_more</span> : <code class="type">int -> int</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>Some field documentations for <code class="code"><span class="constructor">F</span></code></p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>Constructor F documentation</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="EXTENSIONG">G</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.G.last">last</span> : <code class="type">int -> int</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>The last and least field documentation</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>Constructor G documentation</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+<div class="info-desc">
+<p>Two new constructors for ext</p>
+</div>
+</div>
+
+</body></html>
--- /dev/null
+\documentclass[11pt]{article}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{textcomp}
+\usepackage{fullpage}
+\usepackage{url}
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Inline\_records}} : This test focuses on the printing of documentation for inline record
+ within the latex generator.}
+\label{Inline-underscorerecords}\index{Inline-underscorerecords@\verb`Inline_records`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{exception:Inline-underscorerecords.Simple}\begin{ocamldoccode}
+exception Simple
+\end{ocamldoccode}
+\index{Simple@\verb`Simple`}
+\begin{ocamldocdescription}
+A nice exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{exception:Inline-underscorerecords.Less}\begin{ocamldoccode}
+exception Less of int
+\end{ocamldoccode}
+\index{Less@\verb`Less`}
+\begin{ocamldocdescription}
+A less simple exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.ext}\begin{ocamldoccode}
+type ext = ..
+\end{ocamldoccode}
+\index{ext@\verb`ext`}
+\begin{ocamldocdescription}
+An open sum type
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.r}\begin{ocamldoccode}
+type r =
+{\char123} lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for non-inline, {\tt{lbl : int}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More documentation for r, {\tt{more : int list}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\index{r@\verb`r`}
+\begin{ocamldocdescription}
+A simple record type for reference
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.t}\begin{ocamldoccode}
+type t =
+ | A of {\char123} lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor documentation
+
+
+\end{ocamldoccomment}
+\index{t@\verb`t`}
+\begin{ocamldocdescription}
+A sum type with one inline record
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.s}\begin{ocamldoccode}
+type s =
+ | B of {\char123} a_label_for_B : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ more_label_for_B : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor B documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ | C of {\char123} c_has_label_too : float ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{C}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ more_than_one : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+$\ldots$ documentations
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor C documentation
+
+
+\end{ocamldoccomment}
+\index{s@\verb`s`}
+\begin{ocamldocdescription}
+A sum type with two inline records
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.any}\begin{ocamldoccode}
+type any =
+ | D : {\char123} any : {\textquotesingle}a ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field {\tt{any:{\textquotesingle}a}} for {\tt{D}} in {\tt{any}}.
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+ ->
+any
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor D documentation
+
+
+\end{ocamldoccomment}
+\index{any@\verb`any`}
+\begin{ocamldocdescription}
+A gadt constructor
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{exception:Inline-underscorerecords.Error}\begin{ocamldoccode}
+exception Error of {\char123} name : string ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Error field documentation {\tt{name:string}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\index{Error@\verb`Error`}
+
+
+
+
+\begin{ocamldoccode}
+type ext +=
+\end{ocamldoccode}
+\label{extension:Inline-underscorerecords.E}\begin{ocamldoccode}
+ | E of {\char123} yet_another_field : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for {\tt{E}} in ext
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor E documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords.F}\begin{ocamldoccode}
+ | F of {\char123} even_more : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Some field documentations for {\tt{F}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor F documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords.G}\begin{ocamldoccode}
+ | G of {\char123} last : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+The last and least field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor G documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldocdescription}
+Two new constructors for ext
+
+
+\end{ocamldocdescription}
+
+
+\end{document}
--- /dev/null
+.SH NAME
+Inline_records \- This test focuses on the printing of documentation for inline record within the latex generator.
+.SH Module
+Module Inline_records
+.SH Documentation
+.sp
+Module
+.BI "Inline_records"
+ :
+.B sig end
+
+.sp
+This test focuses on the printing of documentation for inline record
+within the latex generator\&.
+
+.sp
+
+.sp
+.sp
+
+.I exception Simple
+
+.sp
+A nice exception
+
+.sp
+
+.I exception Less
+.B of
+.B int
+
+.sp
+A less simple exception
+
+.sp
+.I type ext
+= ..
+
+.sp
+An open sum type
+
+.sp
+.I type r
+= {
+ lbl :
+.B int
+; (* Field documentation for non\-inline,
+.B lbl : int
+
+ *)
+ more :
+.B int list
+; (* More documentation for r,
+.B more : int list
+
+ *)
+ }
+
+.sp
+A simple record type for reference
+
+.sp
+.I type t
+=
+ | A
+.B of {
+ lbl :
+.B int
+; (*
+.B A
+field documentation
+ *)
+ more :
+.B int list
+; (* More
+.B A
+field documentation
+ *)
+ }
+.I " "
+ (* Constructor documentation
+ *)
+
+.sp
+A sum type with one inline record
+
+.sp
+.I type s
+=
+ | B
+.B of {
+ a_label_for_B :
+.B int
+; (*
+.B B
+field documentation
+ *)
+ more_label_for_B :
+.B int list
+; (* More
+.B B
+field documentation
+ *)
+ }
+.I " "
+ (* Constructor B documentation
+ *)
+ | C
+.B of {
+ c_has_label_too :
+.B float
+; (*
+.B C
+field documentation
+ *)
+ more_than_one :
+.B unit
+; (* \&.\&.\&. documentations
+ *)
+ }
+.I " "
+ (* Constructor C documentation
+ *)
+
+.sp
+A sum type with two inline records
+
+.sp
+.I type any
+=
+ | D
+.B of {
+ any :
+.B 'a
+; (*
+.B A
+field
+.B any:\&'a
+for
+.B D
+in
+.B any
+\&.
+ *)
+ }
+.B ->
+.B any
+.I " "
+ (* Constructor D documentation
+ *)
+
+.sp
+A gadt constructor
+
+.sp
+
+.I exception Error
+.B of {
+ name :
+.B string
+; (* Error field documentation
+.B name:string
+
+ *)
+ }
+
+.sp
+
+.sp
+.I type ext
++=
+ | E
+.B of {
+ yet_another_field :
+.B unit
+; (* Field documentation for
+.B E
+in ext
+ *)
+ }
+.I " "
+(* Constructor E documentation
+ *)
+ | F
+.B of {
+ even_more :
+.B int -> int
+; (* Some field documentations for
+.B F
+
+ *)
+ }
+.I " "
+(* Constructor F documentation
+ *)
+ | G
+.B of {
+ last :
+.B int -> int
+; (* The last and least field documentation
+ *)
+ }
+.I " "
+(* Constructor G documentation
+ *)
+
+.sp
+Two new constructors for ext
+
+.sp
--- /dev/null
+(* TEST
+ * ocamldoc with html
+ * ocamldoc with latex
+ * ocamldoc with man
+*)
+
+(**
+ This test focuses on the printing of documentation for inline record
+ within the latex generator.
+*)
+
+
+(** A nice exception *)
+exception Simple
+
+(** A less simple exception *)
+exception Less of int
+
+(** An open sum type *)
+type ext = ..
+
+(** A simple record type for reference *)
+type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
+ more:int list (** More documentation for r, [more : int list] *) }
+
+
+(** A sum type with one inline record *)
+type t = A of {lbl: int (** [A] field documentation *)
+ ; more:int list (** More [A] field documentation *) }
+(** Constructor documentation *)
+
+(** A sum type with two inline records *)
+type s =
+ | B of { a_label_for_B : int (** [B] field documentation *);
+ more_label_for_B:int list (** More [B] field documentation *) }
+ (** Constructor B documentation *)
+ | C of { c_has_label_too: float (** [C] field documentation*);
+ more_than_one: unit (** ... documentations *) }
+ (** Constructor C documentation *)
+
+(** A gadt constructor *)
+type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
+(** Constructor D documentation *)
+
+exception Error of {name:string (** Error field documentation [name:string] *) }
+
+type ext +=
+ | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
+ (** Constructor E documentation *)
+ | F of { even_more: int -> int (** Some field documentations for [F] *) }
+ (** Constructor F documentation *)
+ | G of { last: int -> int (** The last and least field documentation *) }
+ (** Constructor G documentation *)
+(** Two new constructors for ext *)
--- /dev/null
+\documentclass[11pt]{article}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{textcomp}
+\usepackage{fullpage}
+\usepackage{url}
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Inline\_records\_bis}} : This test focuses on the printing of documentation for inline record
+ within the latex generator.}
+\label{Inline-underscorerecords-underscorebis}\index{Inline-underscorerecords-underscorebis@\verb`Inline_records_bis`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{exception:Inline-underscorerecords-underscorebis.Simple}\begin{ocamldoccode}
+exception Simple
+\end{ocamldoccode}
+\index{Simple@\verb`Simple`}
+\begin{ocamldocdescription}
+A nice exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{exception:Inline-underscorerecords-underscorebis.Less}\begin{ocamldoccode}
+exception Less of int
+\end{ocamldoccode}
+\index{Less@\verb`Less`}
+\begin{ocamldocdescription}
+A less simple exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.ext}\begin{ocamldoccode}
+type ext = ..
+\end{ocamldoccode}
+\index{ext@\verb`ext`}
+\begin{ocamldocdescription}
+An open sum type
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.r}\begin{ocamldoccode}
+type r =
+{\char123} lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for non-inline, {\tt{lbl : int}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More documentation for r, {\tt{more : int list}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\index{r@\verb`r`}
+\begin{ocamldocdescription}
+A simple record type for reference
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.t}\begin{ocamldoccode}
+type t =
+ | A of {\char123} lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor documentation
+
+
+\end{ocamldoccomment}
+\index{t@\verb`t`}
+\begin{ocamldocdescription}
+A sum type with one inline record
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.s}\begin{ocamldoccode}
+type s =
+ | B of {\char123} a_label_for_B : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ more_label_for_B : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor B documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ | C of {\char123} c_has_label_too : float ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{C}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ more_than_one : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+$\ldots$ documentations
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor C documentation
+
+
+\end{ocamldoccomment}
+\index{s@\verb`s`}
+\begin{ocamldocdescription}
+A sum type with two inline records
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.any}\begin{ocamldoccode}
+type any =
+ | D : {\char123} any : {\textquotesingle}a ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field {\tt{any:{\textquotesingle}a}} for {\tt{D}} in {\tt{any}}.
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+ ->
+any
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor D documentation
+
+
+\end{ocamldoccomment}
+\index{any@\verb`any`}
+\begin{ocamldocdescription}
+A gadt constructor
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{exception:Inline-underscorerecords-underscorebis.Error}\begin{ocamldoccode}
+exception Error of {\char123} name : string ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Error field documentation {\tt{name:string}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\index{Error@\verb`Error`}
+
+
+
+
+\begin{ocamldoccode}
+type ext +=
+\end{ocamldoccode}
+\label{extension:Inline-underscorerecords-underscorebis.E}\begin{ocamldoccode}
+ | E of {\char123} yet_another_field : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for {\tt{E}} in ext
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor E documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords-underscorebis.F}\begin{ocamldoccode}
+ | F of {\char123} even_more : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Some field documentations for {\tt{F}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor F documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords-underscorebis.G}\begin{ocamldoccode}
+ | G of {\char123} last : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+The last and least field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor G documentation
+
+
+\end{ocamldoccomment}
+
+
+
+
+Two new constructors for ext
+
+\end{document}
--- /dev/null
+(* TEST
+ * ocamldoc with latex
+*)
+
+(**
+ This test focuses on the printing of documentation for inline record
+ within the latex generator.
+*)
+
+
+(** A nice exception *)
+exception Simple
+
+(** A less simple exception *)
+exception Less of int
+
+(** An open sum type *)
+type ext = ..
+
+(** A simple record type for reference *)
+type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
+ more:int list (** More documentation for r, [more : int list] *) }
+
+
+(** A sum type with one inline record *)
+type t = A of {lbl: int (** [A] field documentation *)
+ ; more:int list (** More [A] field documentation *) }
+(** Constructor documentation *)
+
+(** A sum type with two inline records *)
+type s =
+ | B of { a_label_for_B : int (** [B] field documentation *);
+ more_label_for_B:int list (** More [B] field documentation *) }
+ (** Constructor B documentation *)
+ | C of { c_has_label_too: float (** [C] field documentation*);
+ more_than_one: unit (** ... documentations *) }
+ (** Constructor C documentation *)
+
+(** A gadt constructor *)
+type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
+(** Constructor D documentation *)
+
+exception Error of {name:string (** Error field documentation [name:string] *) }
+
+type ext +=
+ | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
+ (** Constructor E documentation *)
+ | F of { even_more: int -> int (** Some field documentations for [F] *) }
+ (** Constructor F documentation *)
+ | G of { last: int -> int (** The last and least field documentation *) }
+ (** Constructor G documentation *)
+(** Two new constructors for ext *)
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of types" rel=Appendix href="index_types.html">
+<link title="Index of extensions" rel=Appendix href="index_extensions.html">
+<link title="Index of exceptions" rel=Appendix href="index_exceptions.html">
+<link title="Index of values" rel=Appendix href="index_values.html">
+<link title="Index of classes" rel=Appendix href="index_classes.html">
+<link title="Index of class types" rel=Appendix href="index_class_types.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Index of module types" rel=Appendix href="index_module_types.html">
+<link title="Item_ids" rel="Chapter" href="Item_ids.html"><title>Item_ids</title>
+</head>
+<body>
+<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
+ </div>
+<h1>Module <a href="type_Item_ids.html">Item_ids</a></h1>
+
+<pre><span id="MODULEItem_ids"><span class="keyword">module</span> Item_ids</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Item_ids.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+<div class="info-desc">
+<p>Check that all toplevel items are given a unique id.</p>
+</div>
+</div>
+<hr width="100%">
+
+<pre><span id="EXCEPTIONEx"><span class="keyword">exception</span> Ex</span></pre>
+
+<pre><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> </pre>
+
+
+<pre><span id="VALx"><span class="keyword">val</span> x</span> : <code class="type"><a href="Item_ids.html#TYPEt">t</a></code></pre>
+<pre><span id="TYPEext"><span class="keyword">type</span> <code class="type"></code>ext</span> = ..</pre>
+
+<pre><code><span class="keyword">type</span> <code class="type"></code><a href="Item_ids.html#TYPEext">ext</a> += </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="EXTENSIONA">A</span></code></td>
+
+</tr></table>
+
+
+
+<pre><span id="TYPEc"><span class="keyword">class</span> <a href="Item_ids.c-c.html">c</a></span> : <code class="type"></code><code class="code"><span class="keyword">object</span></code> <a href="Item_ids.c-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
+<pre><span id="TYPEct"><span class="keyword">class type</span> <a href="Item_ids.ct-c.html">ct</a></span> = <code class="code"><span class="keyword">object</span></code> <a href="Item_ids.ct-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
+<pre><span id="MODULEM"><span class="keyword">module</span> <a href="Item_ids.M.html">M</a></span>: <code class="code"><span class="keyword">sig</span></code> <a href="Item_ids.M.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
+<pre><span id="MODULETYPEs"><span class="keyword">module type</span> <a href="Item_ids.s-c.html">s</a></span> = <code class="code"><span class="keyword">sig</span></code> <a href="Item_ids.s-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre></body></html>
--- /dev/null
+(* TEST
+ * ocamldoc with html
+*)
+
+(** Check that all toplevel items are given a unique id. *)
+
+exception Ex
+type t
+val x: t
+type ext = ..
+type ext += A
+class c: object end
+class type ct= object end
+[@@@attribute]
+module M: sig end
+module type s = sig end
--- /dev/null
+\documentclass[11pt]{article}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{textcomp}
+\usepackage{fullpage}
+\usepackage{url}
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Level\_0}} : Test for level 0 headings }
+\label{Level-underscore0}\index{Level-underscore0@\verb`Level_0`}
+
+
+
+ \subsection*{Level 1}
+
+
+
+ Standard heading levels start at 1.
+
+
+ \section{Level 0}
+
+ A level 0 heading is guaranted to be at the same level that
+ the main heading of the module.
+
+
+ This setup allows users to start their standard heading at level 1 rather
+ than 2, without losing the ability to add global level heading,
+ when, if ever, such heading is warranted
+
+
+
+\ocamldocvspace{0.5cm}
+
+\end{document}
--- /dev/null
+(* TEST
+ * ocamldoc with latex
+*)
+
+(** Test for level 0 headings
+
+ {1 Level 1}
+
+ Standard heading levels start at 1.
+
+ {0 Level 0}
+ A level 0 heading is guaranted to be at the same level that
+ the main heading of the module.
+
+ This setup allows users to start their standard heading at level 1 rather
+ than 2, without losing the ability to add global level heading,
+ when, if ever, such heading is warranted
+
+ *)
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of types" rel=Appendix href="index_types.html">
+<link title="Index of extensions" rel=Appendix href="index_extensions.html">
+<link title="Index of exceptions" rel=Appendix href="index_exceptions.html">
+<link title="Index of values" rel=Appendix href="index_values.html">
+<link title="Index of class types" rel=Appendix href="index_class_types.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Index of module types" rel=Appendix href="index_module_types.html">
+<link title="Linebreaks" rel="Chapter" href="Linebreaks.html"><title>Linebreaks</title>
+</head>
+<body>
+<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
+ </div>
+<h1>Module <a href="type_Linebreaks.html">Linebreaks</a></h1>
+
+<pre><span id="MODULELinebreaks"><span class="keyword">module</span> Linebreaks</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+<div class="info-desc">
+<p>This file tests the encoding of linebreak inside OCaml code by the
+ ocamldoc html backend.</p>
+
+<p>Two slightly different aspects are tested in this very file.</p>
+
+<ul>
+<li>First, inside a "pre" tags, blanks character should not be escaped.
+ For instance, the generated html code for this test fragment should not
+ contain any <br> tag:
+ <pre class="codepre"><code class="code"> <span class="keyword">let</span> f x =
+ <span class="keyword">let</span> g x =
+ <span class="keyword">let</span> h x = x <span class="keyword">in</span>
+ h x <span class="keyword">in</span>
+ g x
+ </code></pre>
+ See <a href="http://caml.inria.fr/mantis/view.php?id=6341"> MPR#6341</a> for more
+ details or the file Linebreaks.html generated by ocamldoc from this file.</li>
+<li>Second, outside of a "pre" tags, blank characters in embedded code
+ should be escaped, in order to make them render in a "pre"-like fashion.
+ A good example should be the files type_<i>Modulename</i>.html generated by
+ ocamldoc that should contains the signature of the module <code class="code"><span class="constructor">Modulename</span></code> in
+ a "code" tags.
+ For instance with the following type definitions,</li>
+</ul>
+</div>
+</div>
+<hr width="100%">
+
+<pre><code><span id="TYPEa"><span class="keyword">type</span> <code class="type"></code>a</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTa.A"><span class="constructor">A</span></span></code></td>
+
+</tr></table>
+
+
+
+<pre><code><span id="TYPEb"><span class="keyword">type</span> <code class="type">'a</code> b</span> = {</code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTb.field">field</span> : <code class="type">'a</code>;</code></td>
+
+</tr></table>
+}
+
+
+
+<pre><code><span id="TYPEc"><span class="keyword">type</span> <code class="type"></code>c</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTc.C"><span class="constructor">C</span></span> <span class="keyword">:</span> <code class="type">'a</code> <span class="keyword">-></span> <code class="type"><a href="Linebreaks.html#TYPEc">c</a></code></code></td>
+
+</tr></table>
+
+
+
+<pre><span id="TYPEs"><span class="keyword">type</span> <code class="type"></code>s</span> = ..</pre>
+
+<pre><code><span class="keyword">type</span> <code class="type"></code><a href="Linebreaks.html#TYPEs">s</a> += </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="EXTENSIONB">B</span></code></td>
+
+</tr></table>
+
+
+
+<pre><span id="VALx"><span class="keyword">val</span> x</span> : <code class="type"><a href="Linebreaks.html#TYPEa">a</a></code></pre>
+<pre><span id="MODULES"><span class="keyword">module</span> <a href="Linebreaks.S.html">S</a></span>: <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.S.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
+<pre><span id="MODULETYPEs"><span class="keyword">module type</span> <a href="Linebreaks.s-c.html">s</a></span> = <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.s-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
+<pre><span id="TYPEd"><span class="keyword">class type</span> <a href="Linebreaks.d-c.html">d</a></span> = <code class="code"><span class="keyword">object</span></code> <a href="Linebreaks.d-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
+<pre><span id="EXCEPTIONE"><span class="keyword">exception</span> E</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTLinebreaks.E.inline">inline</span> : <code class="type">int</code>;</code></td>
+
+</tr></table>
+}
+</pre>
+<p>type_Linebreaks.html should contain</p>
+
+<pre class="codepre"><code class="code"><span class="keyword">sig</span>
+ <span class="keyword">type</span> a = <span class="constructor">A</span>
+ <span class="keyword">type</span> <span class="keywordsign">'</span>a b = { field : <span class="keywordsign">'</span>a; }
+ <span class="keyword">type</span> c = <span class="constructor">C</span> : <span class="keywordsign">'</span>a <span class="keywordsign">-></span> <span class="constructor">Linebreaks</span>.c
+ <span class="keyword">type</span> s = ..
+ <span class="keyword">type</span> s += <span class="constructor">B</span>
+ <span class="keyword">val</span> x : <span class="constructor">Linebreaks</span>.a
+ <span class="keyword">module</span> <span class="constructor">S</span> : <span class="keyword">sig</span> <span class="keyword">module</span> <span class="constructor">I</span> : <span class="keyword">sig</span> <span class="keyword">end</span> <span class="keyword">end</span>
+ <span class="keyword">module</span> <span class="keyword">type</span> s = <span class="keyword">sig</span> <span class="keyword">end</span>
+ <span class="keyword">class</span> <span class="keyword">type</span> d = <span class="keyword">object</span> <span class="keyword">end</span>
+ <span class="keyword">exception</span> <span class="constructor">E</span> <span class="keyword">of</span> { inline : int; }
+<span class="keyword">end</span>
+</code></pre>
+<p>with <br> tags used for linebreaks.
+Another example would be <code class="code"> <span class="keyword">let</span> f x =<br>
+x</code> which is rendered with a <br> linebreak inside Linebreaks.html.</p>
+
+<p>See <a href="http://caml.inria.fr/mantis/view.php?id=7272">MPR#7272</a> for more
+information.</p>
+</body></html>
--- /dev/null
+(* TEST
+ * ocamldoc with html
+ ** check-program-output
+ output="type_Linebreaks.html"
+ reference="${test_source_directory}/type_Linebreaks.reference"
+*)
+
+(**
+ This file tests the encoding of linebreak inside OCaml code by the
+ ocamldoc html backend.
+
+ Two slightly different aspects are tested in this very file.
+
+ - First, inside a "pre" tags, blanks character should not be escaped.
+ For instance, the generated html code for this test fragment should not
+ contain any <br> tag:
+ {[
+ let f x =
+ let g x =
+ let h x = x in
+ h x in
+ g x
+ ]}
+ See {{:http://caml.inria.fr/mantis/view.php?id=6341} MPR#6341} for more
+ details or the file Linebreaks.html generated by ocamldoc from this file.
+ - Second, outside of a "pre" tags, blank characters in embedded code
+ should be escaped, in order to make them render in a "pre"-like fashion.
+ A good example should be the files type_{i Modulename}.html generated by
+ ocamldoc that should contains the signature of the module [Modulename] in
+ a "code" tags.
+ For instance with the following type definitions,
+*)
+
+type a = A
+type 'a b = {field:'a}
+type c = C: 'a -> c
+
+type s = ..
+type s += B
+
+val x : a
+
+module S: sig module I:sig end end
+module type s = sig end
+
+class type d = object end
+
+exception E of {inline:int}
+
+
+(** type_Linebreaks.html should contain
+
+{[
+sig
+ type a = A
+ type 'a b = { field : 'a; }
+ type c = C : 'a -> Linebreaks.c
+ type s = ..
+ type s += B
+ val x : Linebreaks.a
+ module S : sig module I : sig end end
+ module type s = sig end
+ class type d = object end
+ exception E of { inline : int; }
+end
+]}
+
+with <br> tags used for linebreaks.
+Another example would be [ let f x =
+x] which is rendered with a <br> linebreak inside Linebreaks.html.
+
+See {{:http://caml.inria.fr/mantis/view.php?id=7272}MPR#7272} for more
+information.
+
+*)
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Loop" rel="Chapter" href="Loop.html"><title>Loop</title>
+</head>
+<body>
+<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
+ </div>
+<h1>Module <a href="type_Loop.html">Loop</a></h1>
+
+<pre><span id="MODULELoop"><span class="keyword">module</span> Loop</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Loop.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><hr width="100%">
+
+<pre><span id="MODULEA"><span class="keyword">module</span> <a href="Loop.A.html">A</a></span>: <code class="type"><a href="Loop.B.html">B</a></code></pre>
+<pre><span id="MODULEB"><span class="keyword">module</span> <a href="Loop.B.html">B</a></span>: <code class="type"><a href="Loop.A.html">A</a></code></pre></body></html>
--- /dev/null
+\documentclass[11pt]{article}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{textcomp}
+\usepackage{fullpage}
+\usepackage{url}
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Loop}}}
+\label{Loop}\index{Loop@\verb`Loop`}
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{A}}{\tt{ : }}\end{ocamldoccode}
+\label{Loop.A}\index{A@\verb`A`}
+
+{\tt{B}}
+
+
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{B}}{\tt{ : }}\end{ocamldoccode}
+\label{Loop.B}\index{B@\verb`B`}
+
+{\tt{A}}
+
+
+
+\end{document}
--- /dev/null
+(* TEST
+ * ocamldoc with html
+ * ocamldoc with latex
+*)
+module rec A : sig type t end = B and B : sig type t = A.t end = A;;
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-CUSTOM_MODULE=odoc_test
-COMPFLAGS=-I $(OTOPDIR)/ocamldoc
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
-DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)
-
-.PHONY: default
-default:
- @if ! $(SUPPORTS_SHARED_LIBRARIES); then \
- echo 'skipped (shared libraries not available)'; \
- else \
- $(SET_LD_PATH) $(MAKE) run; \
- fi
-
-.PHONY: run
-run: $(CUSTOM_MODULE).cmo
- @for file in t*.ml; do \
- printf " ... testing '$$file'"; \
- F="`basename $$file .ml`"; \
- $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -g $(CUSTOM_MODULE).cmo \
- -o $$F.result $$file; \
- $(DIFF) $$F.reference $$F.result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done;
- @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings -html t*.ml 2>&1 \
- | grep -v test_types_display || true
- @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings -latex t*.ml 2>&1 \
- | grep -v test_types_display || true
-
-.PHONY: promote
-promote: defaultpromote
-
-.PHONY: clean
-clean: defaultclean
- @rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux
-
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Module_whitespace" rel="Chapter" href="Module_whitespace.html"><title>Module_whitespace</title>
+</head>
+<body>
+<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
+ </div>
+<h1>Module <a href="type_Module_whitespace.html">Module_whitespace</a></h1>
+
+<pre><span id="MODULEModule_whitespace"><span class="keyword">module</span> Module_whitespace</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Module_whitespace.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><hr width="100%">
+
+<pre><span id="MODULEM"><span class="keyword">module</span> <a href="Module_whitespace.M.html">M</a></span>: <code class="type">Stdlib.Set.Make</code><code class="code">(</code><code class="code"><span class="keyword">sig</span></code></pre><div class="sig_block">
+<pre><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> = <code class="type">int</code> </pre>
+
+
+<pre><span id="VALcompare"><span class="keyword">val</span> compare</span> : <code class="type">'a -> 'a -> int</code></pre></div>
+<pre><code class="code"><span class="keyword">end</span></code><code class="code">)</code></pre></body></html>
--- /dev/null
+(* TEST
+ * ocamldoc with html
+*)
+
+module M = Set.Make(struct
+ type t = int
+ let compare = compare
+end)
--- /dev/null
+Warning: Module or module type Stdlib.Set.Make not found
+Warning: Module or module type Stdlib.Set.Make not found
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of values" rel=Appendix href="index_values.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="No_preamble" rel="Chapter" href="No_preamble.html"><title>No_preamble</title>
+</head>
+<body>
+<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
+ </div>
+<h1>Module <a href="type_No_preamble.html">No_preamble</a></h1>
+
+<pre><span id="MODULENo_preamble"><span class="keyword">module</span> No_preamble</span>: <code class="code"><span class="keyword">sig</span></code> <a href="No_preamble.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><hr width="100%">
+
+<pre><span id="VALx"><span class="keyword">val</span> x</span> : <code class="type">unit</code></pre><div class="info ">
+<div class="info-desc">
+<p>This is a documentation comment for <code class="code">x</code>, not a module preamble.</p>
+</div>
+</div>
+</body></html>
--- /dev/null
+(* TEST
+ * ocamldoc with html
+*)
+
+open String
+
+(** This is a documentation comment for [x], not a module preamble. *)
+val x: unit
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of types" rel=Appendix href="index_types.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Paragraph" rel="Chapter" href="Paragraph.html"><title>Paragraph</title>
+</head>
+<body>
+<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
+ </div>
+<h1>Module <a href="type_Paragraph.html">Paragraph</a></h1>
+
+<pre><span id="MODULEParagraph"><span class="keyword">module</span> Paragraph</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Paragraph.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+<div class="info-desc">
+<p>This file tests the generation of paragraph within module comments.</p>
+
+<p>At least three points should be exercised in this tests</p>
+
+<ul>
+<li>First, all text should be tagged</li>
+<li>Second, no paragraph should contain only spaces characters</li>
+<li>Third, the mixing of different text style should not create
+ invalid p tags</li>
+</ul>
+<p>See also <a href=" http://caml.inria.fr/mantis/view.php?id=7352"> MPR:7352</a>,
+ <a href=" http://caml.inria.fr/mantis/view.php?id=7353"> MPR:7353</a></p>
+
+<h3 id="here">Testing non-text elements </h3>
+<p><code class="code">code x </code> <i>should </i> be inside a p.</p>
+
+<p><em>But</em> <b>not</b></p>
+<pre class="codepre"><code class="code"> <span class="keyword">let</span> complex_code = ()
+ </code></pre><p>here.</p>
+
+<OL>
+<li>An enumerated list first element</li>
+<li>second element</li>
+</OL>
+<div align=left>Alignement test: left</div><div align=right>Right</div><center>Center</center>
+<p>Other complex text<sub class="subscript">in subscript </sub><sup class="superscript">and superscript</sup></p>
+
+<p>There is also html specific elements.</p>
+</div>
+<ul class="info-attributes">
+<li><b>Author(s):</b> : Florian Angeletti</li>
+<li><b>Version:</b> : 1</li>
+</ul>
+</div>
+<hr width="100%">
+
+<pre><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> </pre>
+<div class="info ">
+<div class="info-desc">
+<p>And cross-reference <a href="Paragraph.html#TYPEt"><code class="code"><span class="constructor">Paragraph</span>.t</code></a>.
+
+<table class="indextable module-list">
+<tr><td class="module"><a href="Paragraph.html">Paragraph</a></td><td><div class="info">
+<p>This file tests the generation of paragraph within module comments.</p>
+
+</div>
+</td></tr>
+</table></p>
+<ul class="indexlist">
+<li><a href="index_types.html">Index of types</a></li>
+<li><a href="index_modules.html">Index of modules</a></li>
+</ul>
+</div>
+</div>
+
+</body></html>
--- /dev/null
+(* TEST
+ * ocamldoc with html
+*)
+
+(** This file tests the generation of paragraph within module comments.
+
+
+ At least three points should be exercised in this tests
+
+ - First, all text should be tagged
+ - Second, no paragraph should contain only spaces characters
+ - Third, the mixing of different text style should not create
+ invalid p tags
+
+
+ See also {{: http://caml.inria.fr/mantis/view.php?id=7352} MPR:7352},
+ {{: http://caml.inria.fr/mantis/view.php?id=7353} MPR:7353}
+
+ {2:here Testing non-text elements }
+
+ [code x ] {i should } be inside a p.
+
+
+ {e But} {b not}
+ {[
+ let complex_code = ()
+ ]}
+ here.
+
+ + An enumerated list first element
+ + second element
+
+ {L Alignement test: left}
+ {R Right}
+ {C Center}
+
+
+ Other complex text{_ in subscript }{^ and superscript}
+ {V Verbatim V}
+
+ There is also {%html: html specific %} elements.
+
+ @author: Florian Angeletti
+ @version: 1
+*)
+
+(** *)
+
+type t
+(**
+ And cross-reference {! t}.
+ {!modules: Paragraph}
+ {!indexlist}
+*)
--- /dev/null
+\documentclass[11pt]{article}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{textcomp}
+\usepackage{fullpage}
+\usepackage{url}
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Short\_description : (* TEST
+ * ocamldoc with latex
+*)}
+\label{Short-underscoredescription}\index{Short-underscoredescription@\verb`Short_description`}
+
+
+
+Short global description in text mode
+
+
+This file tests that documentation in text mode are given
+a short description in the global description of modules.
+
+
+
+
+\end{document}
--- /dev/null
+(* TEST
+ * ocamldoc with latex
+*)
+
+Short global description in text mode
+
+This file tests that documentation in text mode are given
+a short description in the global description of modules.
--- /dev/null
+\documentclass[11pt]{article}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{textcomp}
+\usepackage{fullpage}
+\usepackage{url}
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Test}} : Ten comments for tests}
+\label{Test}\index{Test@\verb`Test`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\subsection*{A first comments for title }
+
+
+
+
+\subsubsection*{A subsection for ocamldoc *}
+
+
+
+
+\subsubsection*{Bis }
+
+
+
+
+\subsubsection*{Ter }
+
+
+
+
+\subsection*{A new section }
+
+
+
+
+\subsubsection*{And its subsection }
+
+
+
+
+\subsubsection*{Encore }
+
+
+
+
+Encore! Encore!
+
+
+
+\subsubsection*{With strange aeons }
+
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{End}}{\tt{ : }}\end{ocamldoccode}
+\label{Test.End}\index{End@\verb`End`}
+
+\begin{ocamldocsigend}
+\end{ocamldocsigend}
+
+
+
+
+\end{document}
--- /dev/null
+(* TEST
+ * ocamldoc with latex
+*)
+
+(** Ten comments for tests *)
+
+(** {6 A first comments for title } *)
+
+(** {7 A subsection for ocamldoc *} *)
+
+(** {7 Bis } *)
+
+(** {7 Ter } *)
+
+(** {6 A new section } *)
+
+(** {7 And its subsection } *)
+
+(** {7 Encore } *)
+
+(** Encore! Encore! *)
+
+
+(**/**)
+module Silence : sig
+ (** At last *)
+end
+
+(**/**)
+
+(** {7 With strange aeons } *)
+
+module End : sig end
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of types" rel=Appendix href="index_types.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Variants" rel="Chapter" href="Variants.html"><title>Variants</title>
+</head>
+<body>
+<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
+ </div>
+<h1>Module <a href="type_Variants.html">Variants</a></h1>
+
+<pre><span id="MODULEVariants"><span class="keyword">module</span> Variants</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Variants.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+<div class="info-desc">
+<p>This test is here to check the latex code generated for variants</p>
+</div>
+</div>
+<hr width="100%">
+
+<pre><code><span id="TYPEs"><span class="keyword">type</span> <code class="type"></code>s</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTs.A"><span class="constructor">A</span></span></code></td>
+
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTs.B"><span class="constructor">B</span></span></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>only B is documented here</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTs.C"><span class="constructor">C</span></span></code></td>
+
+</tr></table>
+
+
+
+<pre><code><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTt.A"><span class="constructor">A</span></span></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>doc for A.</p>
+<pre class="codepre"><code class="code">0</code></pre><p>With three paragraphs.</p>
+<pre class="codepre"><code class="code">1</code></pre><p>To check styling</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTt.B"><span class="constructor">B</span></span></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>doc for B</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+
+
+<pre><code><span id="TYPEu"><span class="keyword">type</span> <code class="type"></code>u</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTu.A"><span class="constructor">A</span></span></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>doc for A</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTu.B"><span class="constructor">B</span></span> <span class="keyword">of</span> <code class="type">unit</code></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>doc for B</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+<div class="info-desc">
+<p>Some documentation for u</p>
+</div>
+</div>
+
+
+<pre><code><span id="TYPEw"><span class="keyword">type</span> <code class="type"></code>w</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTw.A"><span class="constructor">A</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTVariants.A.x">x</span> : <code class="type">int</code>;</code></td>
+
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>doc for A</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTw.B"><span class="constructor">B</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTVariants.B.y">y</span> : <code class="type">int</code>;</code></td>
+
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>doc for B</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+<div class="info-desc">
+<p>With records</p>
+</div>
+</div>
+
+
+<pre><code><span id="TYPEz"><span class="keyword">type</span> <code class="type"></code>z</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTz.A"><span class="constructor">A</span></span> <span class="keyword">of</span> <code class="type">int</code></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>doc for A</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTz.B"><span class="constructor">B</span></span> <span class="keyword">of</span> <code class="type">int</code></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>doc for B</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+<div class="info-desc">
+<p>With args</p>
+</div>
+</div>
+
+
+<pre><code><span id="TYPEa"><span class="keyword">type</span> <code class="type"></code>a</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTa.A"><span class="constructor">A</span></span> <span class="keyword">:</span> <code class="type"><a href="Variants.html#TYPEa">a</a></code></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>doc for A</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+<div class="info-desc">
+<p>Gadt notation</p>
+</div>
+</div>
+
+
+<pre><code><span id="TYPEb"><span class="keyword">type</span> <code class="type"></code>b</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTb.B"><span class="constructor">B</span></span></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<div class="info-desc">
+<p>doc for B</p>
+</div>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+<div class="info-desc">
+<p>Lonely constructor</p>
+</div>
+</div>
+
+
+<pre><code><span id="TYPEno_documentation"><span class="keyword">type</span> <code class="type"></code>no_documentation</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTno_documentation.A"><span class="constructor">A</span></span></code></td>
+
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTno_documentation.B"><span class="constructor">B</span></span></code></td>
+
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTno_documentation.C"><span class="constructor">C</span></span></code></td>
+
+</tr></table>
+
+
+
+<pre><code><span id="TYPEe"><span class="keyword">type</span> <code class="type"></code>e</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code></table>
+
+<div class="info ">
+<div class="info-desc">
+<p>Empty variant</p>
+</div>
+</div>
+
+</body></html>
--- /dev/null
+\documentclass[11pt]{article}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{textcomp}
+\usepackage{fullpage}
+\usepackage{url}
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Variants}} : This test is here to check the latex code generated for variants}
+\label{Variants}\index{Variants@\verb`Variants`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{TYPVariants.s}\begin{ocamldoccode}
+type s =
+ | A
+ | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+only B is documented here
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ | C
+\end{ocamldoccode}
+\index{s@\verb`s`}
+
+
+
+
+\label{TYPVariants.t}\begin{ocamldoccode}
+type t =
+ | A
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A.
+ \begin{ocamldoccode}
+0
+\end{ocamldoccode}
+
+ With three paragraphs.
+ \begin{ocamldoccode}
+1
+\end{ocamldoccode}
+
+ To check styling
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{t@\verb`t`}
+
+
+
+
+\label{TYPVariants.u}\begin{ocamldoccode}
+type u =
+ | A
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ | B of unit
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{u@\verb`u`}
+\begin{ocamldocdescription}
+Some documentation for u
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.w}\begin{ocamldoccode}
+type w =
+ | A of {\char123} x : int ;
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ | B of {\char123} y : int ;
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{w@\verb`w`}
+\begin{ocamldocdescription}
+With records
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.z}\begin{ocamldoccode}
+type z =
+ | A of int
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ | B of int
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{z@\verb`z`}
+\begin{ocamldocdescription}
+With args
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.a}\begin{ocamldoccode}
+type a =
+ | A : a
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A
+
+
+\end{ocamldoccomment}
+\index{a@\verb`a`}
+\begin{ocamldocdescription}
+Gadt notation
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.b}\begin{ocamldoccode}
+type b =
+ | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{b@\verb`b`}
+\begin{ocamldocdescription}
+Lonely constructor
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.no-underscoredocumentation}\begin{ocamldoccode}
+type no_documentation =
+ | A
+ | B
+ | C
+\end{ocamldoccode}
+\index{no-underscoredocumentation@\verb`no_documentation`}
+
+
+
+
+\label{TYPVariants.e}\begin{ocamldoccode}
+type e =
+ |
+\end{ocamldoccode}
+\index{e@\verb`e`}
+\begin{ocamldocdescription}
+Empty variant
+
+
+\end{ocamldocdescription}
+
+
+\end{document}
--- /dev/null
+(* TEST
+ * ocamldoc with html
+ * ocamldoc with latex
+*)
+
+(** This test is here to check the latex code generated for variants *)
+
+type s = A | B (** only B is documented here *) | C
+
+type t =
+ | A
+ (** doc for A.
+ {[0]}
+ With three paragraphs.
+ {[1]}
+ To check styling
+ *)
+ | B
+ (** doc for B *)
+
+(** Some documentation for u*)
+type u =
+| A (** doc for A *) | B of unit (** doc for B *)
+
+
+(** With records *)
+type w =
+| A of { x: int }
+ (** doc for A *)
+| B of { y:int }
+ (** doc for B *)
+
+(** With args *)
+type z =
+| A of int
+ (** doc for A *)
+| B of int
+ (** doc for B *)
+
+(** Gadt notation *)
+type a =
+ A: a (** doc for A*)
+
+(** Lonely constructor *)
+type b =
+ B (** doc for B *)
+
+type no_documentation = A | B | C
+
+(** Empty variant *)
+type e = |
--- /dev/null
+Documentation_tags.mli
+Extensible_variant.ml
+Inline_records.mli
+Inline_records_bis.ml
+Item_ids.mli
+Paragraph.mli
+Module_whitespace.ml
+No_preamble.mli
+Level_0.mli
+Linebreaks.mli
+Loop.ml
+Short_description.txt
+t01.ml
+t02.ml
+t03.ml
+t04.ml
+t05.ml
+Test.mli
+Variants.mli
+(* TEST
+ plugins="odoc_test.ml"
+ * ocamldoc
+ flags="-I ${ocamlsrcdir}/ocamldoc"
+*)
+
(** Testing display of types.
@test_types_display
+(* TEST
+ plugins="odoc_test.ml"
+ * ocamldoc
+ flags="-I ${ocamlsrcdir}/ocamldoc"
+*)
+
module Foo = struct type u type t = int let x = 1 end;;
module type TFoo = module type of Foo;;
+(* TEST
+ plugins="odoc_test.ml"
+ * ocamldoc
+ flags="-I ${ocamlsrcdir}/ocamldoc"
+*)
+
module Foo = struct type t = int let x = 1 end;;
module type MT = module type of Foo;;
module Bar = struct type t = int let x = 2 end;;
--- /dev/null
+Warning: Module type not found
+(* TEST
+ plugins="odoc_test.ml"
+ * ocamldoc
+ flags="-I ${ocamlsrcdir}/ocamldoc"
+*)
+
(** Testing display of inline record.
@test_types_display
+(* TEST
+ plugins="odoc_test.ml"
+ * ocamldoc
+ flags="-I ${ocamlsrcdir}/ocamldoc"
+*)
module rec A : sig type t end = B and B : sig type t = A.t end = A;;
-
--- /dev/null
+<html><head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link title="Index of types" rel=Appendix href="index_types.html">
+<link title="Index of extensions" rel=Appendix href="index_extensions.html">
+<link title="Index of exceptions" rel=Appendix href="index_exceptions.html">
+<link title="Index of values" rel=Appendix href="index_values.html">
+<link title="Index of class types" rel=Appendix href="index_class_types.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Index of module types" rel=Appendix href="index_module_types.html">
+<link title="Linebreaks" rel="Chapter" href="Linebreaks.html"><title>Linebreaks</title>
+</head>
+<body>
+<code class="code"><span class="keyword">sig</span><br>
+ <span class="keyword">type</span> a = <span class="constructor">A</span><br>
+ <span class="keyword">type</span> <span class="keywordsign">'</span>a b = { field : <span class="keywordsign">'</span>a; }<br>
+ <span class="keyword">type</span> c = <span class="constructor">C</span> : <span class="keywordsign">'</span>a <span class="keywordsign">-></span> <span class="constructor">Linebreaks</span>.c<br>
+ <span class="keyword">type</span> s = ..<br>
+ <span class="keyword">type</span> s += <span class="constructor">B</span><br>
+ <span class="keyword">val</span> x : <span class="constructor">Linebreaks</span>.a<br>
+ <span class="keyword">module</span> <span class="constructor">S</span> : <span class="keyword">sig</span> <span class="keyword">module</span> <span class="constructor">I</span> : <span class="keyword">sig</span> <span class="keyword">end</span> <span class="keyword">end</span><br>
+ <span class="keyword">module</span> <span class="keyword">type</span> s = <span class="keyword">sig</span> <span class="keyword">end</span><br>
+ <span class="keyword">class</span> <span class="keyword">type</span> d = <span class="keyword">object</span> <span class="keyword">end</span><br>
+ <span class="keyword">exception</span> <span class="constructor">E</span> <span class="keyword">of</span> { inline : int; }<br>
+<span class="keyword">end</span></code></body></html>
+++ /dev/null
-BASEDIR=../..
-
-LD_PATH=
-
-# This test ensures that ocamlobjinfo is behaving as the configuration
-# expects and is a guard against the breakage fixed in 17fc532
-
-.PHONY: default
-default:
- @printf " ... testing 'ocamlobjinfo'"
- @if ! $(SUPPORTS_SHARED_LIBRARIES) || $(BYTECODE_ONLY) ; then \
- echo ' => skipped (.cmxs not built)'; \
- elif ! grep -q HAS_LIBBFD $(TOPDIR)/byterun/caml/s.h ; then \
- echo ' => skipped (BFD library not available)'; \
- else \
- $(SET_LD_PATH) OCAMLLIB=$(TOPDIR)/tools $(MAKE) run; \
- fi
-
-.PHONY: run
-run:
- @rm -f $(MAIN_MODULE).result
- @$(OCAMLOPT) -shared -o question.cmxs question.ml
- @$(OCAMLRUN) `$(CYGPATH) $(TOPDIR)/tools/ocamlobjinfo` \
- question.cmxs \
- > test.raw.result 2>&1 \
- && sed -e 's/\([^0-9a-z]\)[0-9a-z]\{32\}\([^0-9a-z]\|$$\)/\1<MD5>\2/' \
- test.raw.result > test.result \
- && $(DIFF) test.reference test.result > /dev/null \
- && echo " => passed" || echo " => failed"
-
-.PHONY: promote
-promote: defaultpromote
-
-.PHONY: clean
-clean: defaultclean
- @rm -f *.result
-
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+#!/bin/sh
+
+if grep -q HAS_LIBBFD ${ocamlsrcdir}/byterun/caml/s.h; then
+ exit ${TEST_PASS};
+fi
+echo libbfd not available > ${ocamltest_response}
+exit ${TEST_SKIP}
--- /dev/null
+question.ml
+(* TEST
+script = "sh ${test_source_directory}/has-lib-bfd.sh"
+* shared-libraries
+** script
+*** setup-ocamlopt.byte-build-env
+**** ocamlopt.byte
+flags = "-shared"
+all_modules = "question.ml"
+program = "question.cmxs"
+***** check-ocamlopt.byte-output
+****** ocamlobjinfo
+******* check-program-output
+*)
+
let answer = 42
--- /dev/null
+File question.cmxs
+Name: Question
+CRC of implementation: 00000000000000000000000000000000
+Globals defined:
+ Question
+Interfaces imported:
+ 00000000000000000000000000000000 Stdlib
+ 00000000000000000000000000000000 Question
+ 00000000000000000000000000000000 CamlinternalFormatBasics
+Implementations imported:
+++ /dev/null
-File question.cmxs
-Name: Question
-CRC of implementation: <MD5>
-Globals defined:
- Question
-Interfaces imported:
- <MD5> Question
- <MD5> Pervasives
- <MD5> CamlinternalFormatBasics
-Implementations imported:
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Bernhard Schommer *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-
-
-default:
- @for file in *.txt; do \
- TERM=dumb $(OCAML) -args $$file < test.ml 2>&1 \
- | grep -v '^ OCaml version' > $$file.result; \
- done
- @for file in *.reference; do \
- printf " ... testing '$$file':"; \
- $(DIFF) $$file `basename $$file reference`result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done
-
-
-promote: defaultpromote
-
-clean: defaultclean
- @rm -f *.result
-
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+
+files = "first_arg_fail.txt last_arg_fail.txt"
+
+* setup-ocaml-build-env
+
+** ocaml
+flags = "-args ${test_source_directory}/first_arg_fail.txt"
+compiler_reference = "${test_source_directory}/first_arg_fail.txt.reference"
+compiler_output = "${test_build_directory}/first_arg_fail.output"
+ocaml_exit_status = "2"
+*** check-ocaml-output
+
+** ocaml
+flags = "-args ${test_source_directory}/indirect_first_arg_fail.txt"
+compiler_reference = "${test_source_directory}/indirect_first_arg_fail.txt.reference"
+compiler_output = "${test_build_directory}/indirect_first_arg_fail.output"
+ocaml_exit_status = "2"
+*** check-ocaml-output
+
+** ocaml
+flags = "-args ${test_source_directory}/indirect_last_arg_fail.txt"
+compiler_reference = "${test_source_directory}/indirect_last_arg_fail.txt.reference"
+compiler_output = "${test_build_directory}/indirect_last_arg_fail.output"
+ocaml_exit_status = "2"
+*** check-ocaml-output
+
+** ocaml
+flags = "-args ${test_source_directory}/last_arg_fail.txt"
+compiler_reference = "${test_source_directory}/last_arg_fail.txt.reference"
+compiler_output = "${test_build_directory}/last_arg_fail.output"
+ocaml_exit_status = "2"
+*** check-ocaml-output
+
+** ocaml
+flags = "-args ${test_source_directory}/working_arg.txt"
+compiler_reference = "${test_source_directory}/working_arg.txt.reference"
+compiler_output = "${test_build_directory}/working_arg.output"
+*** check-ocaml-output
+
+*)
+
printf "Test succeeds\n";;
-
-# Test succeeds
+Test succeeds
- : unit = ()
-#
+
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
-TOPFLAGS+=-I $(OTOPDIR)/toplevel
--- /dev/null
+module L : sig type ('a, 'b) t = [] | (::) of 'a * ('b, 'a) t end
+- : (int list, string) L.t =
+L.(::) ([1; 2],
+ L.(::) ("2", L.(::) ([3; 4], L.(::) ("4", L.(::) ([5], L.[])))))
+- : (int, string) L.t =
+(::) (1, (::) ("2", (::) (3, (::) ("4", (::) (5, [])))))
+module L : sig type 'a t = 'a list = [] | (::) of 'a * 'a t end
+- : int L.t L.t =
+L.(::) (L.(::) (1, L.[]),
+ L.(::) (L.(::) (2, L.[]),
+ L.(::) (L.(::) (3, L.[]),
+ L.(::) (L.(::) (4, L.[]), L.(::) (L.(::) (5, L.[]), L.[])))))
+- : int L.t = (::) (1, (::) (2, (::) (3, (::) (4, (::) (5, [])))))
+
+(* TEST
+ * toplevel
+*)
+
module L = struct
type ('a,'b) t = [] | (::) of 'a * ('b,'a) t
end;;
+++ /dev/null
-
-# module L : sig type ('a, 'b) t = [] | (::) of 'a * ('b, 'a) t end
-# - : (int list, string) L.t =
-L.(::) ([1; 2],
- L.(::) ("2", L.(::) ([3; 4], L.(::) ("4", L.(::) ([5], L.[])))))
-# # - : (int, string) L.t =
-(::) (1, (::) ("2", (::) (3, (::) ("4", (::) (5, [])))))
-# module L : sig type 'a t = 'a list = [] | (::) of 'a * 'a t end
-# - : int L.t L.t =
-L.(::) (L.(::) (1, L.[]),
- L.(::) (L.(::) (2, L.[]),
- L.(::) (L.(::) (3, L.[]),
- L.(::) (L.(::) (4, L.[]), L.(::) (L.(::) (5, L.[]), L.[])))))
-# # - : int L.t = (::) (1, (::) (2, (::) (3, (::) (4, (::) (5, [])))))
-#
--- /dev/null
+exotic_lists.ml
+pr7060.ml
+pr7751.ml
+strings.ml
+tracing.ml
--- /dev/null
+type t = A | B
+type u = C of t
+Characters 18-54:
+ let print_t out = function A -> Format.fprintf out "A";;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+B
+val print_t : Format.formatter -> t -> unit = <fun>
+- : t =
+<printer print_t raised an exception: File "//toplevel//", line 5, characters -8--3: Pattern matching failed>
+- : u =
+C
+ <printer print_t raised an exception: File "//toplevel//", line 5, characters -8--3: Pattern matching failed>
+
+(* TEST
+ * toplevel
+*)
+
type t = A | B;;
type u = C of t;;
let print_t out = function A -> Format.fprintf out "A";;
+++ /dev/null
-
-# type t = A | B
-# type u = C of t
-# Characters 18-54:
- let print_t out = function A -> Format.fprintf out "A";;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-B
-val print_t : Format.formatter -> t -> unit = <fun>
-# # - : t =
-<printer print_t raised an exception: File "//toplevel//", line 1, characters 18-23: Pattern matching failed>
-# - : u =
-C
- <printer print_t raised an exception: File "//toplevel//", line 1, characters 18-23: Pattern matching failed>
-#
--- /dev/null
+- : Parsetree.expression =
+{Parsetree.pexp_desc =
+ Parsetree.Pexp_constant (Parsetree.Pconst_integer ("1", None));
+ pexp_loc =
+ {Location.loc_start =
+ {Lexing.pos_fname = ""; pos_lnum = 1; pos_bol = 0; pos_cnum = 0};
+ loc_end = {Lexing.pos_fname = ""; pos_lnum = 1; pos_bol = 0; pos_cnum = 1};
+ loc_ghost = false};
+ pexp_attributes = []}
+
--- /dev/null
+(* TEST
+ include ocamlcommon
+ * toplevel
+*)
+
+Parse.expression (Lexing.from_string "1");;
--- /dev/null
+- : string = "\n\t\r\b"
+- : string = "\"\\'"
+- : string =
+" !#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_`abcdefghijklmnopqrstuvwxyz{|}~"
+- : string =
+"\000\001\002\003\004\005\006\007\011\012\014\015\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031\127"
+- : string =
+"\"Ἀχιλλεύς\r\n天照\tब्रह्मन्\t𒄑 𒂆 𒈦 𒄑 𒂆 𒈦\\"
+- : string = "ایدهآل"
+
+(* TEST
+ * toplevel
+*)
+
(* Test the printing of strings in the terminal *)
"\n\t\r\b";;
+++ /dev/null
-
-# - : string = "\n\t\r\b"
-# - : string = "\"\\'"
-# - : string =
-" !#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_`abcdefghijklmnopqrstuvwxyz{|}~"
-# - : string =
-"\000\001\002\003\004\005\006\007\011\012\014\015\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031\127"
-# - : string =
-"\"Ἀχιλλεύς\r\n天照\tब्रह्मन्\t𒄑 𒂆 𒈦 𒄑 𒂆 𒈦\\"
-# - : string = "ایدهآل"
-#
--- /dev/null
+- : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a = <fun>
+List.fold_left is now traced.
+- : int = 0
+List.fold_left <-- <fun>
+List.fold_left --> <fun>
+List.fold_left* <-- <poly>
+List.fold_left* --> <fun>
+List.fold_left** <-- [<poly>; <poly>; <poly>]
+List.fold_left <-- <fun>
+List.fold_left --> <fun>
+List.fold_left* <-- <poly>
+List.fold_left* --> <fun>
+List.fold_left** <-- [<poly>; <poly>]
+List.fold_left <-- <fun>
+List.fold_left --> <fun>
+List.fold_left* <-- <poly>
+List.fold_left* --> <fun>
+List.fold_left** <-- [<poly>]
+List.fold_left <-- <fun>
+List.fold_left --> <fun>
+List.fold_left* <-- <poly>
+List.fold_left* --> <fun>
+List.fold_left** <-- []
+List.fold_left** --> <poly>
+List.fold_left** --> <poly>
+List.fold_left** --> <poly>
+List.fold_left** --> <poly>
+- : int = 6
+
+(* TEST
+ * toplevel
+*)
+
List.fold_left;;
#trace List.fold_left;;
0;;
+++ /dev/null
-
-# - : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a = <fun>
-# List.fold_left is now traced.
-# - : int = 0
-# List.fold_left <-- <fun>
-List.fold_left --> <fun>
-List.fold_left* <-- <poly>
-List.fold_left* --> <fun>
-List.fold_left** <-- [<poly>; <poly>; <poly>]
-List.fold_left <-- <fun>
-List.fold_left --> <fun>
-List.fold_left* <-- <poly>
-List.fold_left* --> <fun>
-List.fold_left** <-- [<poly>; <poly>]
-List.fold_left <-- <fun>
-List.fold_left --> <fun>
-List.fold_left* <-- <poly>
-List.fold_left* --> <fun>
-List.fold_left** <-- [<poly>]
-List.fold_left <-- <fun>
-List.fold_left --> <fun>
-List.fold_left* <-- <poly>
-List.fold_left* --> <fun>
-List.fold_left** <-- []
-List.fold_left** --> <poly>
-List.fold_left** --> <poly>
-List.fold_left** --> <poly>
-List.fold_left** --> <poly>
-- : int = 6
-#
+++ /dev/null
-newdefault: array_spec.ml.reference module_coercion.ml.reference
- $(MAKE) default
-
-BASEDIR=../..
-TOPFLAGS+=-dlambda
-include $(BASEDIR)/makefiles/Makefile.dlambda
-include $(BASEDIR)/makefiles/Makefile.common
-
-GENERATED_SOURCES = array_spec.ml.reference module_coercion.ml.reference \
- *.flat-float
-
-ifeq "$(FLAT_FLOAT_ARRAY)" "true"
-suffix = -flat
-else
-suffix = -noflat
-endif
-
-array_spec.ml.reference: array_spec.ml.reference$(suffix) \
- $(FLAT_FLOAT_ARRAY).flat-float
- cp $< $@
-
-module_coercion.ml.reference: module_coercion.ml.reference$(suffix) \
- $(FLAT_FLOAT_ARRAY).flat-float
- cp $< $@
-
-%.flat-float:
- @rm -f $(GENERATED_SOURCES)
- @touch $@
--- /dev/null
+(setglobal Array_spec!
+ (let
+ (int_a = (makearray[int] 1 2 3)
+ float_a = (makearray[float] 1. 2. 3.)
+ addr_a = (makearray[addr] "a" "b" "c"))
+ (seq (array.length[int] int_a) (array.length[float] float_a)
+ (array.length[addr] addr_a) (function a (array.length[gen] a))
+ (array.get[int] int_a 0) (array.get[float] float_a 0)
+ (array.get[addr] addr_a 0) (function a (array.get[gen] a 0))
+ (array.unsafe_get[int] int_a 0) (array.unsafe_get[float] float_a 0)
+ (array.unsafe_get[addr] addr_a 0)
+ (function a (array.unsafe_get[gen] a 0)) (array.set[int] int_a 0 1)
+ (array.set[float] float_a 0 1.) (array.set[addr] addr_a 0 "a")
+ (function a x (array.set[gen] a 0 x)) (array.unsafe_set[int] int_a 0 1)
+ (array.unsafe_set[float] float_a 0 1.)
+ (array.unsafe_set[addr] addr_a 0 "a")
+ (function a x (array.unsafe_set[gen] a 0 x))
+ (let
+ (eta_gen_len = (function prim stub (array.length[gen] prim))
+ eta_gen_safe_get =
+ (function prim prim stub (array.get[gen] prim prim))
+ eta_gen_unsafe_get =
+ (function prim prim stub (array.unsafe_get[gen] prim prim))
+ eta_gen_safe_set =
+ (function prim prim prim stub (array.set[gen] prim prim prim))
+ eta_gen_unsafe_set =
+ (function prim prim prim stub
+ (array.unsafe_set[gen] prim prim prim))
+ eta_int_len = (function prim stub (array.length[int] prim))
+ eta_int_safe_get =
+ (function prim prim stub (array.get[int] prim prim))
+ eta_int_unsafe_get =
+ (function prim prim stub (array.unsafe_get[int] prim prim))
+ eta_int_safe_set =
+ (function prim prim prim stub (array.set[int] prim prim prim))
+ eta_int_unsafe_set =
+ (function prim prim prim stub
+ (array.unsafe_set[int] prim prim prim))
+ eta_float_len = (function prim stub (array.length[float] prim))
+ eta_float_safe_get =
+ (function prim prim stub (array.get[float] prim prim))
+ eta_float_unsafe_get =
+ (function prim prim stub (array.unsafe_get[float] prim prim))
+ eta_float_safe_set =
+ (function prim prim prim stub (array.set[float] prim prim prim))
+ eta_float_unsafe_set =
+ (function prim prim prim stub
+ (array.unsafe_set[float] prim prim prim))
+ eta_addr_len = (function prim stub (array.length[addr] prim))
+ eta_addr_safe_get =
+ (function prim prim stub (array.get[addr] prim prim))
+ eta_addr_unsafe_get =
+ (function prim prim stub (array.unsafe_get[addr] prim prim))
+ eta_addr_safe_set =
+ (function prim prim prim stub (array.set[addr] prim prim prim))
+ eta_addr_unsafe_set =
+ (function prim prim prim stub
+ (array.unsafe_set[addr] prim prim prim)))
+ (makeblock 0 int_a float_a addr_a eta_gen_len eta_gen_safe_get
+ eta_gen_unsafe_get eta_gen_safe_set eta_gen_unsafe_set eta_int_len
+ eta_int_safe_get eta_int_unsafe_get eta_int_safe_set
+ eta_int_unsafe_set eta_float_len eta_float_safe_get
+ eta_float_unsafe_get eta_float_safe_set eta_float_unsafe_set
+ eta_addr_len eta_addr_safe_get eta_addr_unsafe_get
+ eta_addr_safe_set eta_addr_unsafe_set)))))
--- /dev/null
+(setglobal Array_spec!
+ (let
+ (int_a = (makearray[int] 1 2 3)
+ float_a = (makearray[addr] 1. 2. 3.)
+ addr_a = (makearray[addr] "a" "b" "c"))
+ (seq (array.length[int] int_a) (array.length[addr] float_a)
+ (array.length[addr] addr_a) (function a (array.length[addr] a))
+ (array.get[int] int_a 0) (array.get[addr] float_a 0)
+ (array.get[addr] addr_a 0) (function a (array.get[addr] a 0))
+ (array.unsafe_get[int] int_a 0) (array.unsafe_get[addr] float_a 0)
+ (array.unsafe_get[addr] addr_a 0)
+ (function a (array.unsafe_get[addr] a 0)) (array.set[int] int_a 0 1)
+ (array.set[addr] float_a 0 1.) (array.set[addr] addr_a 0 "a")
+ (function a x (array.set[addr] a 0 x))
+ (array.unsafe_set[int] int_a 0 1) (array.unsafe_set[addr] float_a 0 1.)
+ (array.unsafe_set[addr] addr_a 0 "a")
+ (function a x (array.unsafe_set[addr] a 0 x))
+ (let
+ (eta_gen_len = (function prim stub (array.length[addr] prim))
+ eta_gen_safe_get =
+ (function prim prim stub (array.get[addr] prim prim))
+ eta_gen_unsafe_get =
+ (function prim prim stub (array.unsafe_get[addr] prim prim))
+ eta_gen_safe_set =
+ (function prim prim prim stub (array.set[addr] prim prim prim))
+ eta_gen_unsafe_set =
+ (function prim prim prim stub
+ (array.unsafe_set[addr] prim prim prim))
+ eta_int_len = (function prim stub (array.length[int] prim))
+ eta_int_safe_get =
+ (function prim prim stub (array.get[int] prim prim))
+ eta_int_unsafe_get =
+ (function prim prim stub (array.unsafe_get[int] prim prim))
+ eta_int_safe_set =
+ (function prim prim prim stub (array.set[int] prim prim prim))
+ eta_int_unsafe_set =
+ (function prim prim prim stub
+ (array.unsafe_set[int] prim prim prim))
+ eta_float_len = (function prim stub (array.length[addr] prim))
+ eta_float_safe_get =
+ (function prim prim stub (array.get[addr] prim prim))
+ eta_float_unsafe_get =
+ (function prim prim stub (array.unsafe_get[addr] prim prim))
+ eta_float_safe_set =
+ (function prim prim prim stub (array.set[addr] prim prim prim))
+ eta_float_unsafe_set =
+ (function prim prim prim stub
+ (array.unsafe_set[addr] prim prim prim))
+ eta_addr_len = (function prim stub (array.length[addr] prim))
+ eta_addr_safe_get =
+ (function prim prim stub (array.get[addr] prim prim))
+ eta_addr_unsafe_get =
+ (function prim prim stub (array.unsafe_get[addr] prim prim))
+ eta_addr_safe_set =
+ (function prim prim prim stub (array.set[addr] prim prim prim))
+ eta_addr_unsafe_set =
+ (function prim prim prim stub
+ (array.unsafe_set[addr] prim prim prim)))
+ (makeblock 0 int_a float_a addr_a eta_gen_len eta_gen_safe_get
+ eta_gen_unsafe_get eta_gen_safe_set eta_gen_unsafe_set eta_int_len
+ eta_int_safe_get eta_int_unsafe_get eta_int_safe_set
+ eta_int_unsafe_set eta_float_len eta_float_safe_get
+ eta_float_unsafe_get eta_float_safe_set eta_float_unsafe_set
+ eta_addr_len eta_addr_safe_get eta_addr_unsafe_get
+ eta_addr_safe_set eta_addr_unsafe_set)))))
+(* TEST
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ flags = "-dlambda -dno-unique-ids"
+ *** flat-float-array
+ **** check-ocamlc.byte-output
+ compiler_reference = "${test_source_directory}/array_spec.compilers.reference.flat"
+ *** no-flat-float-array
+ **** check-ocamlc.byte-output
+ compiler_reference = "${test_source_directory}/array_spec.compilers.reference.no-flat"
+*)
+
external len : 'a array -> int = "%array_length"
external safe_get : 'a array -> int -> 'a = "%array_safe_get"
external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
+++ /dev/null
-(setglobal Array_spec!
- (let
- (int_a = (makearray[int] 1 2 3)
- float_a = (makearray[float] 1. 2. 3.)
- addr_a = (makearray[addr] "a" "b" "c"))
- (seq (array.length[int] int_a) (array.length[float] float_a)
- (array.length[addr] addr_a)
- (function a (array.length[gen] a))
- (array.get[int] int_a 0) (array.get[float] float_a 0)
- (array.get[addr] addr_a 0)
- (function a (array.get[gen] a 0))
- (array.unsafe_get[int] int_a 0)
- (array.unsafe_get[float] float_a 0)
- (array.unsafe_get[addr] addr_a 0)
- (function a (array.unsafe_get[gen] a 0))
- (array.set[int] int_a 0 1) (array.set[float] float_a 0 1.)
- (array.set[addr] addr_a 0 "a")
- (function a x (array.set[gen] a 0 x))
- (array.unsafe_set[int] int_a 0 1)
- (array.unsafe_set[float] float_a 0 1.)
- (array.unsafe_set[addr] addr_a 0 "a")
- (function a x (array.unsafe_set[gen] a 0 x))
- (let
- (eta_gen_len =
- (function prim stub (array.length[gen] prim))
- eta_gen_safe_get =
- (function prim prim stub
- (array.get[gen] prim prim))
- eta_gen_unsafe_get =
- (function prim prim stub
- (array.unsafe_get[gen] prim prim))
- eta_gen_safe_set =
- (function prim prim prim stub
- (array.set[gen] prim prim prim))
- eta_gen_unsafe_set =
- (function prim prim prim stub
- (array.unsafe_set[gen] prim prim prim))
- eta_int_len =
- (function prim stub (array.length[int] prim))
- eta_int_safe_get =
- (function prim prim stub
- (array.get[int] prim prim))
- eta_int_unsafe_get =
- (function prim prim stub
- (array.unsafe_get[int] prim prim))
- eta_int_safe_set =
- (function prim prim prim stub
- (array.set[int] prim prim prim))
- eta_int_unsafe_set =
- (function prim prim prim stub
- (array.unsafe_set[int] prim prim prim))
- eta_float_len =
- (function prim stub (array.length[float] prim))
- eta_float_safe_get =
- (function prim prim stub
- (array.get[float] prim prim))
- eta_float_unsafe_get =
- (function prim prim stub
- (array.unsafe_get[float] prim prim))
- eta_float_safe_set =
- (function prim prim prim stub
- (array.set[float] prim prim prim))
- eta_float_unsafe_set =
- (function prim prim prim stub
- (array.unsafe_set[float] prim prim prim))
- eta_addr_len =
- (function prim stub (array.length[addr] prim))
- eta_addr_safe_get =
- (function prim prim stub
- (array.get[addr] prim prim))
- eta_addr_unsafe_get =
- (function prim prim stub
- (array.unsafe_get[addr] prim prim))
- eta_addr_safe_set =
- (function prim prim prim stub
- (array.set[addr] prim prim prim))
- eta_addr_unsafe_set =
- (function prim prim prim stub
- (array.unsafe_set[addr] prim prim prim)))
- (makeblock 0 int_a float_a addr_a eta_gen_len
- eta_gen_safe_get eta_gen_unsafe_get eta_gen_safe_set
- eta_gen_unsafe_set eta_int_len eta_int_safe_get
- eta_int_unsafe_get eta_int_safe_set
- eta_int_unsafe_set eta_float_len eta_float_safe_get
- eta_float_unsafe_get eta_float_safe_set
- eta_float_unsafe_set eta_addr_len eta_addr_safe_get
- eta_addr_unsafe_get eta_addr_safe_set
- eta_addr_unsafe_set)))))
+++ /dev/null
-(setglobal Array_spec!
- (let
- (int_a = (makearray[int] 1 2 3)
- float_a = (makearray[addr] 1. 2. 3.)
- addr_a = (makearray[addr] "a" "b" "c"))
- (seq (array.length[int] int_a) (array.length[addr] float_a)
- (array.length[addr] addr_a)
- (function a (array.length[addr] a))
- (array.get[int] int_a 0) (array.get[addr] float_a 0)
- (array.get[addr] addr_a 0)
- (function a (array.get[addr] a 0))
- (array.unsafe_get[int] int_a 0)
- (array.unsafe_get[addr] float_a 0)
- (array.unsafe_get[addr] addr_a 0)
- (function a (array.unsafe_get[addr] a 0))
- (array.set[int] int_a 0 1) (array.set[addr] float_a 0 1.)
- (array.set[addr] addr_a 0 "a")
- (function a x (array.set[addr] a 0 x))
- (array.unsafe_set[int] int_a 0 1)
- (array.unsafe_set[addr] float_a 0 1.)
- (array.unsafe_set[addr] addr_a 0 "a")
- (function a x (array.unsafe_set[addr] a 0 x))
- (let
- (eta_gen_len =
- (function prim stub (array.length[addr] prim))
- eta_gen_safe_get =
- (function prim prim stub
- (array.get[addr] prim prim))
- eta_gen_unsafe_get =
- (function prim prim stub
- (array.unsafe_get[addr] prim prim))
- eta_gen_safe_set =
- (function prim prim prim stub
- (array.set[addr] prim prim prim))
- eta_gen_unsafe_set =
- (function prim prim prim stub
- (array.unsafe_set[addr] prim prim prim))
- eta_int_len =
- (function prim stub (array.length[int] prim))
- eta_int_safe_get =
- (function prim prim stub
- (array.get[int] prim prim))
- eta_int_unsafe_get =
- (function prim prim stub
- (array.unsafe_get[int] prim prim))
- eta_int_safe_set =
- (function prim prim prim stub
- (array.set[int] prim prim prim))
- eta_int_unsafe_set =
- (function prim prim prim stub
- (array.unsafe_set[int] prim prim prim))
- eta_float_len =
- (function prim stub (array.length[addr] prim))
- eta_float_safe_get =
- (function prim prim stub
- (array.get[addr] prim prim))
- eta_float_unsafe_get =
- (function prim prim stub
- (array.unsafe_get[addr] prim prim))
- eta_float_safe_set =
- (function prim prim prim stub
- (array.set[addr] prim prim prim))
- eta_float_unsafe_set =
- (function prim prim prim stub
- (array.unsafe_set[addr] prim prim prim))
- eta_addr_len =
- (function prim stub (array.length[addr] prim))
- eta_addr_safe_get =
- (function prim prim stub
- (array.get[addr] prim prim))
- eta_addr_unsafe_get =
- (function prim prim stub
- (array.unsafe_get[addr] prim prim))
- eta_addr_safe_set =
- (function prim prim prim stub
- (array.set[addr] prim prim prim))
- eta_addr_unsafe_set =
- (function prim prim prim stub
- (array.unsafe_set[addr] prim prim prim)))
- (makeblock 0 int_a float_a addr_a eta_gen_len
- eta_gen_safe_get eta_gen_unsafe_get eta_gen_safe_set
- eta_gen_unsafe_set eta_int_len eta_int_safe_get
- eta_int_unsafe_get eta_int_safe_set
- eta_int_unsafe_set eta_float_len eta_float_safe_get
- eta_float_unsafe_get eta_float_safe_set
- eta_float_unsafe_set eta_addr_len eta_addr_safe_get
- eta_addr_unsafe_get eta_addr_safe_set
- eta_addr_unsafe_set)))))
--- /dev/null
+(setglobal Comparison_table!
+ (let
+ (gen_cmp = (function x y (caml_compare x y))
+ int_cmp = (function x y (caml_int_compare x y))
+ bool_cmp = (function x y (caml_int_compare x y))
+ intlike_cmp = (function x y (caml_int_compare x y))
+ float_cmp = (function x y (caml_float_compare x y))
+ string_cmp = (function x y (caml_string_compare x y))
+ int32_cmp = (function x y (caml_int32_compare x y))
+ int64_cmp = (function x y (caml_int64_compare x y))
+ nativeint_cmp = (function x y (caml_nativeint_compare x y))
+ gen_eq = (function x y (caml_equal x y))
+ int_eq = (function x y (== x y))
+ bool_eq = (function x y (== x y))
+ intlike_eq = (function x y (== x y))
+ float_eq = (function x y (==. x y))
+ string_eq = (function x y (caml_string_equal x y))
+ int32_eq = (function x y (Int32.== x y))
+ int64_eq = (function x y (Int64.== x y))
+ nativeint_eq = (function x y (Nativeint.== x y))
+ gen_ne = (function x y (caml_notequal x y))
+ int_ne = (function x y (!= x y))
+ bool_ne = (function x y (!= x y))
+ intlike_ne = (function x y (!= x y))
+ float_ne = (function x y (!=. x y))
+ string_ne = (function x y (caml_string_notequal x y))
+ int32_ne = (function x y (Int32.!= x y))
+ int64_ne = (function x y (Int64.!= x y))
+ nativeint_ne = (function x y (Nativeint.!= x y))
+ gen_lt = (function x y (caml_lessthan x y))
+ int_lt = (function x y (< x y))
+ bool_lt = (function x y (< x y))
+ intlike_lt = (function x y (< x y))
+ float_lt = (function x y (<. x y))
+ string_lt = (function x y (caml_string_lessthan x y))
+ int32_lt = (function x y (Int32.< x y))
+ int64_lt = (function x y (Int64.< x y))
+ nativeint_lt = (function x y (Nativeint.< x y))
+ gen_gt = (function x y (caml_greaterthan x y))
+ int_gt = (function x y (> x y))
+ bool_gt = (function x y (> x y))
+ intlike_gt = (function x y (> x y))
+ float_gt = (function x y (>. x y))
+ string_gt = (function x y (caml_string_greaterthan x y))
+ int32_gt = (function x y (Int32.> x y))
+ int64_gt = (function x y (Int64.> x y))
+ nativeint_gt = (function x y (Nativeint.> x y))
+ gen_le = (function x y (caml_lessequal x y))
+ int_le = (function x y (<= x y))
+ bool_le = (function x y (<= x y))
+ intlike_le = (function x y (<= x y))
+ float_le = (function x y (<=. x y))
+ string_le = (function x y (caml_string_lessequal x y))
+ int32_le = (function x y (Int32.<= x y))
+ int64_le = (function x y (Int64.<= x y))
+ nativeint_le = (function x y (Nativeint.<= x y))
+ gen_ge = (function x y (caml_greaterequal x y))
+ int_ge = (function x y (>= x y))
+ bool_ge = (function x y (>= x y))
+ intlike_ge = (function x y (>= x y))
+ float_ge = (function x y (>=. x y))
+ string_ge = (function x y (caml_string_greaterequal x y))
+ int32_ge = (function x y (Int32.>= x y))
+ int64_ge = (function x y (Int64.>= x y))
+ nativeint_ge = (function x y (Nativeint.>= x y))
+ eta_gen_cmp = (function prim prim stub (caml_compare prim prim))
+ eta_int_cmp = (function prim prim stub (caml_int_compare prim prim))
+ eta_bool_cmp = (function prim prim stub (caml_int_compare prim prim))
+ eta_intlike_cmp = (function prim prim stub (caml_int_compare prim prim))
+ eta_float_cmp = (function prim prim stub (caml_float_compare prim prim))
+ eta_string_cmp =
+ (function prim prim stub (caml_string_compare prim prim))
+ eta_int32_cmp = (function prim prim stub (caml_int32_compare prim prim))
+ eta_int64_cmp = (function prim prim stub (caml_int64_compare prim prim))
+ eta_nativeint_cmp =
+ (function prim prim stub (caml_nativeint_compare prim prim))
+ eta_gen_eq = (function prim prim stub (caml_equal prim prim))
+ eta_int_eq = (function prim prim stub (== prim prim))
+ eta_bool_eq = (function prim prim stub (== prim prim))
+ eta_intlike_eq = (function prim prim stub (== prim prim))
+ eta_float_eq = (function prim prim stub (==. prim prim))
+ eta_string_eq = (function prim prim stub (caml_string_equal prim prim))
+ eta_int32_eq = (function prim prim stub (Int32.== prim prim))
+ eta_int64_eq = (function prim prim stub (Int64.== prim prim))
+ eta_nativeint_eq = (function prim prim stub (Nativeint.== prim prim))
+ eta_gen_ne = (function prim prim stub (caml_notequal prim prim))
+ eta_int_ne = (function prim prim stub (!= prim prim))
+ eta_bool_ne = (function prim prim stub (!= prim prim))
+ eta_intlike_ne = (function prim prim stub (!= prim prim))
+ eta_float_ne = (function prim prim stub (!=. prim prim))
+ eta_string_ne =
+ (function prim prim stub (caml_string_notequal prim prim))
+ eta_int32_ne = (function prim prim stub (Int32.!= prim prim))
+ eta_int64_ne = (function prim prim stub (Int64.!= prim prim))
+ eta_nativeint_ne = (function prim prim stub (Nativeint.!= prim prim))
+ eta_gen_lt = (function prim prim stub (caml_lessthan prim prim))
+ eta_int_lt = (function prim prim stub (< prim prim))
+ eta_bool_lt = (function prim prim stub (< prim prim))
+ eta_intlike_lt = (function prim prim stub (< prim prim))
+ eta_float_lt = (function prim prim stub (<. prim prim))
+ eta_string_lt =
+ (function prim prim stub (caml_string_lessthan prim prim))
+ eta_int32_lt = (function prim prim stub (Int32.< prim prim))
+ eta_int64_lt = (function prim prim stub (Int64.< prim prim))
+ eta_nativeint_lt = (function prim prim stub (Nativeint.< prim prim))
+ eta_gen_gt = (function prim prim stub (caml_greaterthan prim prim))
+ eta_int_gt = (function prim prim stub (> prim prim))
+ eta_bool_gt = (function prim prim stub (> prim prim))
+ eta_intlike_gt = (function prim prim stub (> prim prim))
+ eta_float_gt = (function prim prim stub (>. prim prim))
+ eta_string_gt =
+ (function prim prim stub (caml_string_greaterthan prim prim))
+ eta_int32_gt = (function prim prim stub (Int32.> prim prim))
+ eta_int64_gt = (function prim prim stub (Int64.> prim prim))
+ eta_nativeint_gt = (function prim prim stub (Nativeint.> prim prim))
+ eta_gen_le = (function prim prim stub (caml_lessequal prim prim))
+ eta_int_le = (function prim prim stub (<= prim prim))
+ eta_bool_le = (function prim prim stub (<= prim prim))
+ eta_intlike_le = (function prim prim stub (<= prim prim))
+ eta_float_le = (function prim prim stub (<=. prim prim))
+ eta_string_le =
+ (function prim prim stub (caml_string_lessequal prim prim))
+ eta_int32_le = (function prim prim stub (Int32.<= prim prim))
+ eta_int64_le = (function prim prim stub (Int64.<= prim prim))
+ eta_nativeint_le = (function prim prim stub (Nativeint.<= prim prim))
+ eta_gen_ge = (function prim prim stub (caml_greaterequal prim prim))
+ eta_int_ge = (function prim prim stub (>= prim prim))
+ eta_bool_ge = (function prim prim stub (>= prim prim))
+ eta_intlike_ge = (function prim prim stub (>= prim prim))
+ eta_float_ge = (function prim prim stub (>=. prim prim))
+ eta_string_ge =
+ (function prim prim stub (caml_string_greaterequal prim prim))
+ eta_int32_ge = (function prim prim stub (Int32.>= prim prim))
+ eta_int64_ge = (function prim prim stub (Int64.>= prim prim))
+ eta_nativeint_ge = (function prim prim stub (Nativeint.>= prim prim))
+ int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0a]]]
+ bool_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
+ intlike_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
+ float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0a]]]
+ string_vec = [0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0a]]]
+ int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0a]]]
+ int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0a]]]
+ nativeint_vec = [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0a]]]
+ test_vec =
+ (function cmp eq ne lt gt le ge vec
+ (let
+ (uncurry =
+ (function f param (apply f (field 0 param) (field 1 param)))
+ map =
+ (function f l
+ (apply (field 16 (global Stdlib__list!)) (apply uncurry f) l)))
+ (makeblock 0
+ (makeblock 0 (apply map gen_cmp vec) (apply map cmp vec))
+ (apply map
+ (function gen spec
+ (makeblock 0 (apply map gen vec) (apply map spec vec)))
+ (makeblock 0 (makeblock 0 gen_eq eq)
+ (makeblock 0 (makeblock 0 gen_ne ne)
+ (makeblock 0 (makeblock 0 gen_lt lt)
+ (makeblock 0 (makeblock 0 gen_gt gt)
+ (makeblock 0 (makeblock 0 gen_le le)
+ (makeblock 0 (makeblock 0 gen_ge ge) 0a)))))))))))
+ (seq
+ (apply test_vec int_cmp int_eq int_ne int_lt int_gt int_le int_ge
+ int_vec)
+ (apply test_vec bool_cmp bool_eq bool_ne bool_lt bool_gt bool_le
+ bool_ge bool_vec)
+ (apply test_vec intlike_cmp intlike_eq intlike_ne intlike_lt intlike_gt
+ intlike_le intlike_ge intlike_vec)
+ (apply test_vec float_cmp float_eq float_ne float_lt float_gt float_le
+ float_ge float_vec)
+ (apply test_vec string_cmp string_eq string_ne string_lt string_gt
+ string_le string_ge string_vec)
+ (apply test_vec int32_cmp int32_eq int32_ne int32_lt int32_gt int32_le
+ int32_ge int32_vec)
+ (apply test_vec int64_cmp int64_eq int64_ne int64_lt int64_gt int64_le
+ int64_ge int64_vec)
+ (apply test_vec nativeint_cmp nativeint_eq nativeint_ne nativeint_lt
+ nativeint_gt nativeint_le nativeint_ge nativeint_vec)
+ (let
+ (eta_test_vec =
+ (function cmp eq ne lt gt le ge vec
+ (let
+ (uncurry =
+ (function f param
+ (apply f (field 0 param) (field 1 param)))
+ map =
+ (function f l
+ (apply (field 16 (global Stdlib__list!))
+ (apply uncurry f) l)))
+ (makeblock 0
+ (makeblock 0 (apply map eta_gen_cmp vec)
+ (apply map cmp vec))
+ (apply map
+ (function gen spec
+ (makeblock 0 (apply map gen vec) (apply map spec vec)))
+ (makeblock 0 (makeblock 0 eta_gen_eq eq)
+ (makeblock 0 (makeblock 0 eta_gen_ne ne)
+ (makeblock 0 (makeblock 0 eta_gen_lt lt)
+ (makeblock 0 (makeblock 0 eta_gen_gt gt)
+ (makeblock 0 (makeblock 0 eta_gen_le le)
+ (makeblock 0 (makeblock 0 eta_gen_ge ge) 0a)))))))))))
+ (seq
+ (apply eta_test_vec eta_int_cmp eta_int_eq eta_int_ne eta_int_lt
+ eta_int_gt eta_int_le eta_int_ge int_vec)
+ (apply eta_test_vec eta_bool_cmp eta_bool_eq eta_bool_ne
+ eta_bool_lt eta_bool_gt eta_bool_le eta_bool_ge bool_vec)
+ (apply eta_test_vec eta_intlike_cmp eta_intlike_eq eta_intlike_ne
+ eta_intlike_lt eta_intlike_gt eta_intlike_le eta_intlike_ge
+ intlike_vec)
+ (apply eta_test_vec eta_float_cmp eta_float_eq eta_float_ne
+ eta_float_lt eta_float_gt eta_float_le eta_float_ge float_vec)
+ (apply eta_test_vec eta_string_cmp eta_string_eq eta_string_ne
+ eta_string_lt eta_string_gt eta_string_le eta_string_ge
+ string_vec)
+ (apply eta_test_vec eta_int32_cmp eta_int32_eq eta_int32_ne
+ eta_int32_lt eta_int32_gt eta_int32_le eta_int32_ge int32_vec)
+ (apply eta_test_vec eta_int64_cmp eta_int64_eq eta_int64_ne
+ eta_int64_lt eta_int64_gt eta_int64_le eta_int64_ge int64_vec)
+ (apply eta_test_vec eta_nativeint_cmp eta_nativeint_eq
+ eta_nativeint_ne eta_nativeint_lt eta_nativeint_gt
+ eta_nativeint_le eta_nativeint_ge nativeint_vec)
+ (makeblock 0 gen_cmp int_cmp bool_cmp intlike_cmp float_cmp
+ string_cmp int32_cmp int64_cmp nativeint_cmp gen_eq int_eq
+ bool_eq intlike_eq float_eq string_eq int32_eq int64_eq
+ nativeint_eq gen_ne int_ne bool_ne intlike_ne float_ne string_ne
+ int32_ne int64_ne nativeint_ne gen_lt int_lt bool_lt intlike_lt
+ float_lt string_lt int32_lt int64_lt nativeint_lt gen_gt int_gt
+ bool_gt intlike_gt float_gt string_gt int32_gt int64_gt
+ nativeint_gt gen_le int_le bool_le intlike_le float_le string_le
+ int32_le int64_le nativeint_le gen_ge int_ge bool_ge intlike_ge
+ float_ge string_ge int32_ge int64_ge nativeint_ge eta_gen_cmp
+ eta_int_cmp eta_bool_cmp eta_intlike_cmp eta_float_cmp
+ eta_string_cmp eta_int32_cmp eta_int64_cmp eta_nativeint_cmp
+ eta_gen_eq eta_int_eq eta_bool_eq eta_intlike_eq eta_float_eq
+ eta_string_eq eta_int32_eq eta_int64_eq eta_nativeint_eq
+ eta_gen_ne eta_int_ne eta_bool_ne eta_intlike_ne eta_float_ne
+ eta_string_ne eta_int32_ne eta_int64_ne eta_nativeint_ne
+ eta_gen_lt eta_int_lt eta_bool_lt eta_intlike_lt eta_float_lt
+ eta_string_lt eta_int32_lt eta_int64_lt eta_nativeint_lt
+ eta_gen_gt eta_int_gt eta_bool_gt eta_intlike_gt eta_float_gt
+ eta_string_gt eta_int32_gt eta_int64_gt eta_nativeint_gt
+ eta_gen_le eta_int_le eta_bool_le eta_intlike_le eta_float_le
+ eta_string_le eta_int32_le eta_int64_le eta_nativeint_le
+ eta_gen_ge eta_int_ge eta_bool_ge eta_intlike_ge eta_float_ge
+ eta_string_ge eta_int32_ge eta_int64_ge eta_nativeint_ge int_vec
+ bool_vec intlike_vec float_vec string_vec int32_vec int64_vec
+ nativeint_vec test_vec eta_test_vec))))))
+(* TEST
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ flags = "-dlambda -dno-unique-ids"
+ *** check-ocamlc.byte-output
+*)
+
external cmp : 'a -> 'a -> int = "%compare";;
external eq : 'a -> 'a -> bool = "%equal";;
external ne : 'a -> 'a -> bool = "%notequal";;
+++ /dev/null
-(setglobal Comparison_table!
- (let
- (gen_cmp = (function x y (caml_compare x y))
- int_cmp = (function x y (caml_int_compare x y))
- bool_cmp =
- (function x y (caml_int_compare x y))
- intlike_cmp =
- (function x y (caml_int_compare x y))
- float_cmp =
- (function x y (caml_float_compare x y))
- string_cmp =
- (function x y (caml_string_compare x y))
- int32_cmp =
- (function x y (caml_int32_compare x y))
- int64_cmp =
- (function x y (caml_int64_compare x y))
- nativeint_cmp =
- (function x y (caml_nativeint_compare x y))
- gen_eq = (function x y (caml_equal x y))
- int_eq = (function x y (== x y))
- bool_eq = (function x y (== x y))
- intlike_eq = (function x y (== x y))
- float_eq = (function x y (==. x y))
- string_eq =
- (function x y (caml_string_equal x y))
- int32_eq = (function x y (Int32.== x y))
- int64_eq = (function x y (Int64.== x y))
- nativeint_eq =
- (function x y (Nativeint.== x y))
- gen_ne = (function x y (caml_notequal x y))
- int_ne = (function x y (!= x y))
- bool_ne = (function x y (!= x y))
- intlike_ne = (function x y (!= x y))
- float_ne = (function x y (!=. x y))
- string_ne =
- (function x y (caml_string_notequal x y))
- int32_ne = (function x y (Int32.!= x y))
- int64_ne = (function x y (Int64.!= x y))
- nativeint_ne =
- (function x y (Nativeint.!= x y))
- gen_lt = (function x y (caml_lessthan x y))
- int_lt = (function x y (< x y))
- bool_lt = (function x y (< x y))
- intlike_lt = (function x y (< x y))
- float_lt = (function x y (<. x y))
- string_lt =
- (function x y (caml_string_lessthan x y))
- int32_lt = (function x y (Int32.< x y))
- int64_lt = (function x y (Int64.< x y))
- nativeint_lt = (function x y (Nativeint.< x y))
- gen_gt = (function x y (caml_greaterthan x y))
- int_gt = (function x y (> x y))
- bool_gt = (function x y (> x y))
- intlike_gt = (function x y (> x y))
- float_gt = (function x y (>. x y))
- string_gt =
- (function x y (caml_string_greaterthan x y))
- int32_gt = (function x y (Int32.> x y))
- int64_gt = (function x y (Int64.> x y))
- nativeint_gt = (function x y (Nativeint.> x y))
- gen_le = (function x y (caml_lessequal x y))
- int_le = (function x y (<= x y))
- bool_le = (function x y (<= x y))
- intlike_le = (function x y (<= x y))
- float_le = (function x y (<=. x y))
- string_le =
- (function x y (caml_string_lessequal x y))
- int32_le = (function x y (Int32.<= x y))
- int64_le = (function x y (Int64.<= x y))
- nativeint_le =
- (function x y (Nativeint.<= x y))
- gen_ge = (function x y (caml_greaterequal x y))
- int_ge = (function x y (>= x y))
- bool_ge = (function x y (>= x y))
- intlike_ge = (function x y (>= x y))
- float_ge = (function x y (>=. x y))
- string_ge =
- (function x y (caml_string_greaterequal x y))
- int32_ge = (function x y (Int32.>= x y))
- int64_ge = (function x y (Int64.>= x y))
- nativeint_ge =
- (function x y (Nativeint.>= x y))
- eta_gen_cmp =
- (function prim prim stub (caml_compare prim prim))
- eta_int_cmp =
- (function prim prim stub
- (caml_int_compare prim prim))
- eta_bool_cmp =
- (function prim prim stub
- (caml_int_compare prim prim))
- eta_intlike_cmp =
- (function prim prim stub
- (caml_int_compare prim prim))
- eta_float_cmp =
- (function prim prim stub
- (caml_float_compare prim prim))
- eta_string_cmp =
- (function prim prim stub
- (caml_string_compare prim prim))
- eta_int32_cmp =
- (function prim prim stub
- (caml_int32_compare prim prim))
- eta_int64_cmp =
- (function prim prim stub
- (caml_int64_compare prim prim))
- eta_nativeint_cmp =
- (function prim prim stub
- (caml_nativeint_compare prim prim))
- eta_gen_eq =
- (function prim prim stub (caml_equal prim prim))
- eta_int_eq =
- (function prim prim stub (== prim prim))
- eta_bool_eq =
- (function prim prim stub (== prim prim))
- eta_intlike_eq =
- (function prim prim stub (== prim prim))
- eta_float_eq =
- (function prim prim stub (==. prim prim))
- eta_string_eq =
- (function prim prim stub
- (caml_string_equal prim prim))
- eta_int32_eq =
- (function prim prim stub (Int32.== prim prim))
- eta_int64_eq =
- (function prim prim stub (Int64.== prim prim))
- eta_nativeint_eq =
- (function prim prim stub (Nativeint.== prim prim))
- eta_gen_ne =
- (function prim prim stub
- (caml_notequal prim prim))
- eta_int_ne =
- (function prim prim stub (!= prim prim))
- eta_bool_ne =
- (function prim prim stub (!= prim prim))
- eta_intlike_ne =
- (function prim prim stub (!= prim prim))
- eta_float_ne =
- (function prim prim stub (!=. prim prim))
- eta_string_ne =
- (function prim prim stub
- (caml_string_notequal prim prim))
- eta_int32_ne =
- (function prim prim stub (Int32.!= prim prim))
- eta_int64_ne =
- (function prim prim stub (Int64.!= prim prim))
- eta_nativeint_ne =
- (function prim prim stub (Nativeint.!= prim prim))
- eta_gen_lt =
- (function prim prim stub
- (caml_lessthan prim prim))
- eta_int_lt =
- (function prim prim stub (< prim prim))
- eta_bool_lt =
- (function prim prim stub (< prim prim))
- eta_intlike_lt =
- (function prim prim stub (< prim prim))
- eta_float_lt =
- (function prim prim stub (<. prim prim))
- eta_string_lt =
- (function prim prim stub
- (caml_string_lessthan prim prim))
- eta_int32_lt =
- (function prim prim stub (Int32.< prim prim))
- eta_int64_lt =
- (function prim prim stub (Int64.< prim prim))
- eta_nativeint_lt =
- (function prim prim stub (Nativeint.< prim prim))
- eta_gen_gt =
- (function prim prim stub
- (caml_greaterthan prim prim))
- eta_int_gt =
- (function prim prim stub (> prim prim))
- eta_bool_gt =
- (function prim prim stub (> prim prim))
- eta_intlike_gt =
- (function prim prim stub (> prim prim))
- eta_float_gt =
- (function prim prim stub (>. prim prim))
- eta_string_gt =
- (function prim prim stub
- (caml_string_greaterthan prim prim))
- eta_int32_gt =
- (function prim prim stub (Int32.> prim prim))
- eta_int64_gt =
- (function prim prim stub (Int64.> prim prim))
- eta_nativeint_gt =
- (function prim prim stub (Nativeint.> prim prim))
- eta_gen_le =
- (function prim prim stub
- (caml_lessequal prim prim))
- eta_int_le =
- (function prim prim stub (<= prim prim))
- eta_bool_le =
- (function prim prim stub (<= prim prim))
- eta_intlike_le =
- (function prim prim stub (<= prim prim))
- eta_float_le =
- (function prim prim stub (<=. prim prim))
- eta_string_le =
- (function prim prim stub
- (caml_string_lessequal prim prim))
- eta_int32_le =
- (function prim prim stub (Int32.<= prim prim))
- eta_int64_le =
- (function prim prim stub (Int64.<= prim prim))
- eta_nativeint_le =
- (function prim prim stub (Nativeint.<= prim prim))
- eta_gen_ge =
- (function prim prim stub
- (caml_greaterequal prim prim))
- eta_int_ge =
- (function prim prim stub (>= prim prim))
- eta_bool_ge =
- (function prim prim stub (>= prim prim))
- eta_intlike_ge =
- (function prim prim stub (>= prim prim))
- eta_float_ge =
- (function prim prim stub (>=. prim prim))
- eta_string_ge =
- (function prim prim stub
- (caml_string_greaterequal prim prim))
- eta_int32_ge =
- (function prim prim stub (Int32.>= prim prim))
- eta_int64_ge =
- (function prim prim stub (Int64.>= prim prim))
- eta_nativeint_ge =
- (function prim prim stub (Nativeint.>= prim prim))
- int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0a]]]
- bool_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
- intlike_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
- float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0a]]]
- string_vec =
- [0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0a]]]
- int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0a]]]
- int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0a]]]
- nativeint_vec = [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0a]]]
- test_vec =
- (function cmp eq ne lt gt le ge
- vec
- (let
- (uncurry =
- (function f param
- (apply f (field 0 param) (field 1 param)))
- map =
- (function f l
- (apply (field 16 (global List!)) (apply uncurry f)
- l)))
- (makeblock 0
- (makeblock 0 (apply map gen_cmp vec)
- (apply map cmp vec))
- (apply map
- (function gen spec
- (makeblock 0 (apply map gen vec)
- (apply map spec vec)))
- (makeblock 0 (makeblock 0 gen_eq eq)
- (makeblock 0 (makeblock 0 gen_ne ne)
- (makeblock 0 (makeblock 0 gen_lt lt)
- (makeblock 0 (makeblock 0 gen_gt gt)
- (makeblock 0 (makeblock 0 gen_le le)
- (makeblock 0 (makeblock 0 gen_ge ge) 0a)))))))))))
- (seq
- (apply test_vec int_cmp int_eq int_ne int_lt
- int_gt int_le int_ge int_vec)
- (apply test_vec bool_cmp bool_eq bool_ne
- bool_lt bool_gt bool_le bool_ge bool_vec)
- (apply test_vec intlike_cmp intlike_eq intlike_ne
- intlike_lt intlike_gt intlike_le intlike_ge
- intlike_vec)
- (apply test_vec float_cmp float_eq float_ne
- float_lt float_gt float_le float_ge
- float_vec)
- (apply test_vec string_cmp string_eq string_ne
- string_lt string_gt string_le string_ge
- string_vec)
- (apply test_vec int32_cmp int32_eq int32_ne
- int32_lt int32_gt int32_le int32_ge
- int32_vec)
- (apply test_vec int64_cmp int64_eq int64_ne
- int64_lt int64_gt int64_le int64_ge
- int64_vec)
- (apply test_vec nativeint_cmp nativeint_eq
- nativeint_ne nativeint_lt nativeint_gt
- nativeint_le nativeint_ge nativeint_vec)
- (let
- (eta_test_vec =
- (function cmp eq ne lt gt le ge
- vec
- (let
- (uncurry =
- (function f param
- (apply f (field 0 param) (field 1 param)))
- map =
- (function f l
- (apply (field 16 (global List!))
- (apply uncurry f) l)))
- (makeblock 0
- (makeblock 0 (apply map eta_gen_cmp vec)
- (apply map cmp vec))
- (apply map
- (function gen spec
- (makeblock 0 (apply map gen vec)
- (apply map spec vec)))
- (makeblock 0 (makeblock 0 eta_gen_eq eq)
- (makeblock 0 (makeblock 0 eta_gen_ne ne)
- (makeblock 0 (makeblock 0 eta_gen_lt lt)
- (makeblock 0 (makeblock 0 eta_gen_gt gt)
- (makeblock 0 (makeblock 0 eta_gen_le le)
- (makeblock 0
- (makeblock 0 eta_gen_ge ge) 0a)))))))))))
- (seq
- (apply eta_test_vec eta_int_cmp eta_int_eq
- eta_int_ne eta_int_lt eta_int_gt eta_int_le
- eta_int_ge int_vec)
- (apply eta_test_vec eta_bool_cmp eta_bool_eq
- eta_bool_ne eta_bool_lt eta_bool_gt
- eta_bool_le eta_bool_ge bool_vec)
- (apply eta_test_vec eta_intlike_cmp eta_intlike_eq
- eta_intlike_ne eta_intlike_lt eta_intlike_gt
- eta_intlike_le eta_intlike_ge intlike_vec)
- (apply eta_test_vec eta_float_cmp eta_float_eq
- eta_float_ne eta_float_lt eta_float_gt
- eta_float_le eta_float_ge float_vec)
- (apply eta_test_vec eta_string_cmp eta_string_eq
- eta_string_ne eta_string_lt eta_string_gt
- eta_string_le eta_string_ge string_vec)
- (apply eta_test_vec eta_int32_cmp eta_int32_eq
- eta_int32_ne eta_int32_lt eta_int32_gt
- eta_int32_le eta_int32_ge int32_vec)
- (apply eta_test_vec eta_int64_cmp eta_int64_eq
- eta_int64_ne eta_int64_lt eta_int64_gt
- eta_int64_le eta_int64_ge int64_vec)
- (apply eta_test_vec eta_nativeint_cmp
- eta_nativeint_eq eta_nativeint_ne eta_nativeint_lt
- eta_nativeint_gt eta_nativeint_le eta_nativeint_ge
- nativeint_vec)
- (makeblock 0 gen_cmp int_cmp bool_cmp
- intlike_cmp float_cmp string_cmp int32_cmp
- int64_cmp nativeint_cmp gen_eq int_eq
- bool_eq intlike_eq float_eq string_eq
- int32_eq int64_eq nativeint_eq gen_ne
- int_ne bool_ne intlike_ne float_ne
- string_ne int32_ne int64_ne nativeint_ne
- gen_lt int_lt bool_lt intlike_lt
- float_lt string_lt int32_lt int64_lt
- nativeint_lt gen_gt int_gt bool_gt
- intlike_gt float_gt string_gt int32_gt
- int64_gt nativeint_gt gen_le int_le
- bool_le intlike_le float_le string_le
- int32_le int64_le nativeint_le gen_ge
- int_ge bool_ge intlike_ge float_ge
- string_ge int32_ge int64_ge nativeint_ge
- eta_gen_cmp eta_int_cmp eta_bool_cmp
- eta_intlike_cmp eta_float_cmp eta_string_cmp
- eta_int32_cmp eta_int64_cmp eta_nativeint_cmp
- eta_gen_eq eta_int_eq eta_bool_eq
- eta_intlike_eq eta_float_eq eta_string_eq
- eta_int32_eq eta_int64_eq eta_nativeint_eq
- eta_gen_ne eta_int_ne eta_bool_ne
- eta_intlike_ne eta_float_ne eta_string_ne
- eta_int32_ne eta_int64_ne eta_nativeint_ne
- eta_gen_lt eta_int_lt eta_bool_lt
- eta_intlike_lt eta_float_lt eta_string_lt
- eta_int32_lt eta_int64_lt eta_nativeint_lt
- eta_gen_gt eta_int_gt eta_bool_gt
- eta_intlike_gt eta_float_gt eta_string_gt
- eta_int32_gt eta_int64_gt eta_nativeint_gt
- eta_gen_le eta_int_le eta_bool_le
- eta_intlike_le eta_float_le eta_string_le
- eta_int32_le eta_int64_le eta_nativeint_le
- eta_gen_ge eta_int_ge eta_bool_ge
- eta_intlike_ge eta_float_ge eta_string_ge
- eta_int32_ge eta_int64_ge eta_nativeint_ge
- int_vec bool_vec intlike_vec float_vec
- string_vec int32_vec int64_vec nativeint_vec
- test_vec eta_test_vec))))))
--- /dev/null
+(* TEST *)
+
+let print_loc loc =
+ print_endline loc
+
+let print_file file =
+ print_endline file
+
+let print_line line =
+ print_endline (string_of_int line)
+
+let print_module md =
+ print_endline md
+
+let print_pos (file, line, col1, col2) =
+ Printf.printf "%s, %d, %d, %d\n" file line col1 col2
+
+let () = print_loc __LOC__
+
+let () = print_file __FILE__
+
+let () = print_line __LINE__
+
+let () = print_module __MODULE__
+
+let () = print_pos __POS__
+
+let loc, s1 = __LOC_OF__ "an expression"
+
+let () = print_loc loc
+
+let () = print_endline s1
+
+let line, s2 = __LINE_OF__ "another expression"
+
+let () = print_line line
+
+let () = print_endline s2
+
+let pos, s3 = __POS_OF__ "yet another expression"
+
+let () = print_pos pos
+
+let () = print_endline s3
--- /dev/null
+File "locs.ml", line 18, characters 19-26
+locs.ml
+22
+Locs
+locs.ml, 26, 19, 26
+File "locs.ml", line 28, characters 14-40
+an expression
+34
+another expression
+locs.ml, 40, 14, 49
+yet another expression
--- /dev/null
+(setglobal Module_coercion!
+ (let (M = (module-defn(M) module_coercion.ml(13):417-1116 (makeblock 0)))
+ (makeblock 0 M
+ (module-defn(M_int) module_coercion.ml(44):1533-1572
+ (makeblock 0 (function prim stub (array.length[int] prim))
+ (function prim prim stub (array.get[int] prim prim))
+ (function prim prim stub (array.unsafe_get[int] prim prim))
+ (function prim prim prim stub (array.set[int] prim prim prim))
+ (function prim prim prim stub
+ (array.unsafe_set[int] prim prim prim))
+ (function prim prim stub (caml_int_compare prim prim))
+ (function prim prim stub (== prim prim))
+ (function prim prim stub (!= prim prim))
+ (function prim prim stub (< prim prim))
+ (function prim prim stub (> prim prim))
+ (function prim prim stub (<= prim prim))
+ (function prim prim stub (>= prim prim))))
+ (module-defn(M_float) module_coercion.ml(45):1575-1618
+ (makeblock 0 (function prim stub (array.length[float] prim))
+ (function prim prim stub (array.get[float] prim prim))
+ (function prim prim stub (array.unsafe_get[float] prim prim))
+ (function prim prim prim stub (array.set[float] prim prim prim))
+ (function prim prim prim stub
+ (array.unsafe_set[float] prim prim prim))
+ (function prim prim stub (caml_float_compare prim prim))
+ (function prim prim stub (==. prim prim))
+ (function prim prim stub (!=. prim prim))
+ (function prim prim stub (<. prim prim))
+ (function prim prim stub (>. prim prim))
+ (function prim prim stub (<=. prim prim))
+ (function prim prim stub (>=. prim prim))))
+ (module-defn(M_string) module_coercion.ml(46):1621-1666
+ (makeblock 0 (function prim stub (array.length[addr] prim))
+ (function prim prim stub (array.get[addr] prim prim))
+ (function prim prim stub (array.unsafe_get[addr] prim prim))
+ (function prim prim prim stub (array.set[addr] prim prim prim))
+ (function prim prim prim stub
+ (array.unsafe_set[addr] prim prim prim))
+ (function prim prim stub (caml_string_compare prim prim))
+ (function prim prim stub (caml_string_equal prim prim))
+ (function prim prim stub (caml_string_notequal prim prim))
+ (function prim prim stub (caml_string_lessthan prim prim))
+ (function prim prim stub (caml_string_greaterthan prim prim))
+ (function prim prim stub (caml_string_lessequal prim prim))
+ (function prim prim stub (caml_string_greaterequal prim prim))))
+ (module-defn(M_int32) module_coercion.ml(47):1669-1712
+ (makeblock 0 (function prim stub (array.length[addr] prim))
+ (function prim prim stub (array.get[addr] prim prim))
+ (function prim prim stub (array.unsafe_get[addr] prim prim))
+ (function prim prim prim stub (array.set[addr] prim prim prim))
+ (function prim prim prim stub
+ (array.unsafe_set[addr] prim prim prim))
+ (function prim prim stub (caml_int32_compare prim prim))
+ (function prim prim stub (Int32.== prim prim))
+ (function prim prim stub (Int32.!= prim prim))
+ (function prim prim stub (Int32.< prim prim))
+ (function prim prim stub (Int32.> prim prim))
+ (function prim prim stub (Int32.<= prim prim))
+ (function prim prim stub (Int32.>= prim prim))))
+ (module-defn(M_int64) module_coercion.ml(48):1715-1758
+ (makeblock 0 (function prim stub (array.length[addr] prim))
+ (function prim prim stub (array.get[addr] prim prim))
+ (function prim prim stub (array.unsafe_get[addr] prim prim))
+ (function prim prim prim stub (array.set[addr] prim prim prim))
+ (function prim prim prim stub
+ (array.unsafe_set[addr] prim prim prim))
+ (function prim prim stub (caml_int64_compare prim prim))
+ (function prim prim stub (Int64.== prim prim))
+ (function prim prim stub (Int64.!= prim prim))
+ (function prim prim stub (Int64.< prim prim))
+ (function prim prim stub (Int64.> prim prim))
+ (function prim prim stub (Int64.<= prim prim))
+ (function prim prim stub (Int64.>= prim prim))))
+ (module-defn(M_nativeint) module_coercion.ml(49):1761-1812
+ (makeblock 0 (function prim stub (array.length[addr] prim))
+ (function prim prim stub (array.get[addr] prim prim))
+ (function prim prim stub (array.unsafe_get[addr] prim prim))
+ (function prim prim prim stub (array.set[addr] prim prim prim))
+ (function prim prim prim stub
+ (array.unsafe_set[addr] prim prim prim))
+ (function prim prim stub (caml_nativeint_compare prim prim))
+ (function prim prim stub (Nativeint.== prim prim))
+ (function prim prim stub (Nativeint.!= prim prim))
+ (function prim prim stub (Nativeint.< prim prim))
+ (function prim prim stub (Nativeint.> prim prim))
+ (function prim prim stub (Nativeint.<= prim prim))
+ (function prim prim stub (Nativeint.>= prim prim)))))))
--- /dev/null
+(setglobal Module_coercion!
+ (let (M = (module-defn(M) module_coercion.ml(13):417-1116 (makeblock 0)))
+ (makeblock 0 M
+ (module-defn(M_int) module_coercion.ml(44):1533-1572
+ (makeblock 0 (function prim stub (array.length[int] prim))
+ (function prim prim stub (array.get[int] prim prim))
+ (function prim prim stub (array.unsafe_get[int] prim prim))
+ (function prim prim prim stub (array.set[int] prim prim prim))
+ (function prim prim prim stub
+ (array.unsafe_set[int] prim prim prim))
+ (function prim prim stub (caml_int_compare prim prim))
+ (function prim prim stub (== prim prim))
+ (function prim prim stub (!= prim prim))
+ (function prim prim stub (< prim prim))
+ (function prim prim stub (> prim prim))
+ (function prim prim stub (<= prim prim))
+ (function prim prim stub (>= prim prim))))
+ (module-defn(M_float) module_coercion.ml(45):1575-1618
+ (makeblock 0 (function prim stub (array.length[addr] prim))
+ (function prim prim stub (array.get[addr] prim prim))
+ (function prim prim stub (array.unsafe_get[addr] prim prim))
+ (function prim prim prim stub (array.set[addr] prim prim prim))
+ (function prim prim prim stub
+ (array.unsafe_set[addr] prim prim prim))
+ (function prim prim stub (caml_float_compare prim prim))
+ (function prim prim stub (==. prim prim))
+ (function prim prim stub (!=. prim prim))
+ (function prim prim stub (<. prim prim))
+ (function prim prim stub (>. prim prim))
+ (function prim prim stub (<=. prim prim))
+ (function prim prim stub (>=. prim prim))))
+ (module-defn(M_string) module_coercion.ml(46):1621-1666
+ (makeblock 0 (function prim stub (array.length[addr] prim))
+ (function prim prim stub (array.get[addr] prim prim))
+ (function prim prim stub (array.unsafe_get[addr] prim prim))
+ (function prim prim prim stub (array.set[addr] prim prim prim))
+ (function prim prim prim stub
+ (array.unsafe_set[addr] prim prim prim))
+ (function prim prim stub (caml_string_compare prim prim))
+ (function prim prim stub (caml_string_equal prim prim))
+ (function prim prim stub (caml_string_notequal prim prim))
+ (function prim prim stub (caml_string_lessthan prim prim))
+ (function prim prim stub (caml_string_greaterthan prim prim))
+ (function prim prim stub (caml_string_lessequal prim prim))
+ (function prim prim stub (caml_string_greaterequal prim prim))))
+ (module-defn(M_int32) module_coercion.ml(47):1669-1712
+ (makeblock 0 (function prim stub (array.length[addr] prim))
+ (function prim prim stub (array.get[addr] prim prim))
+ (function prim prim stub (array.unsafe_get[addr] prim prim))
+ (function prim prim prim stub (array.set[addr] prim prim prim))
+ (function prim prim prim stub
+ (array.unsafe_set[addr] prim prim prim))
+ (function prim prim stub (caml_int32_compare prim prim))
+ (function prim prim stub (Int32.== prim prim))
+ (function prim prim stub (Int32.!= prim prim))
+ (function prim prim stub (Int32.< prim prim))
+ (function prim prim stub (Int32.> prim prim))
+ (function prim prim stub (Int32.<= prim prim))
+ (function prim prim stub (Int32.>= prim prim))))
+ (module-defn(M_int64) module_coercion.ml(48):1715-1758
+ (makeblock 0 (function prim stub (array.length[addr] prim))
+ (function prim prim stub (array.get[addr] prim prim))
+ (function prim prim stub (array.unsafe_get[addr] prim prim))
+ (function prim prim prim stub (array.set[addr] prim prim prim))
+ (function prim prim prim stub
+ (array.unsafe_set[addr] prim prim prim))
+ (function prim prim stub (caml_int64_compare prim prim))
+ (function prim prim stub (Int64.== prim prim))
+ (function prim prim stub (Int64.!= prim prim))
+ (function prim prim stub (Int64.< prim prim))
+ (function prim prim stub (Int64.> prim prim))
+ (function prim prim stub (Int64.<= prim prim))
+ (function prim prim stub (Int64.>= prim prim))))
+ (module-defn(M_nativeint) module_coercion.ml(49):1761-1812
+ (makeblock 0 (function prim stub (array.length[addr] prim))
+ (function prim prim stub (array.get[addr] prim prim))
+ (function prim prim stub (array.unsafe_get[addr] prim prim))
+ (function prim prim prim stub (array.set[addr] prim prim prim))
+ (function prim prim prim stub
+ (array.unsafe_set[addr] prim prim prim))
+ (function prim prim stub (caml_nativeint_compare prim prim))
+ (function prim prim stub (Nativeint.== prim prim))
+ (function prim prim stub (Nativeint.!= prim prim))
+ (function prim prim stub (Nativeint.< prim prim))
+ (function prim prim stub (Nativeint.> prim prim))
+ (function prim prim stub (Nativeint.<= prim prim))
+ (function prim prim stub (Nativeint.>= prim prim)))))))
+(* TEST
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ flags = "-dlambda -dno-unique-ids"
+ *** flat-float-array
+ **** check-ocamlc.byte-output
+ compiler_reference = "${test_source_directory}/module_coercion.compilers.reference.flat"
+ *** no-flat-float-array
+ **** check-ocamlc.byte-output
+ compiler_reference = "${test_source_directory}/module_coercion.compilers.reference.no-flat"
+*)
+
module M = struct
external len : 'a array -> int = "%array_length"
external safe_get : 'a array -> int -> 'a = "%array_safe_get"
+++ /dev/null
-(setglobal Module_coercion!
- (let
- (M = (module-defn(M) module_coercion.ml(1):0-699 (makeblock 0)))
- (makeblock 0 M
- (module-defn(M_int) module_coercion.ml(32):1116-1155
- (makeblock 0 (function prim stub (array.length[int] prim))
- (function prim prim stub
- (array.get[int] prim prim))
- (function prim prim stub
- (array.unsafe_get[int] prim prim))
- (function prim prim prim stub
- (array.set[int] prim prim prim))
- (function prim prim prim stub
- (array.unsafe_set[int] prim prim prim))
- (function prim prim stub
- (caml_int_compare prim prim))
- (function prim prim stub (== prim prim))
- (function prim prim stub (!= prim prim))
- (function prim prim stub (< prim prim))
- (function prim prim stub (> prim prim))
- (function prim prim stub (<= prim prim))
- (function prim prim stub (>= prim prim))))
- (module-defn(M_float) module_coercion.ml(33):1158-1201
- (makeblock 0
- (function prim stub (array.length[float] prim))
- (function prim prim stub
- (array.get[float] prim prim))
- (function prim prim stub
- (array.unsafe_get[float] prim prim))
- (function prim prim prim stub
- (array.set[float] prim prim prim))
- (function prim prim prim stub
- (array.unsafe_set[float] prim prim prim))
- (function prim prim stub
- (caml_float_compare prim prim))
- (function prim prim stub (==. prim prim))
- (function prim prim stub (!=. prim prim))
- (function prim prim stub (<. prim prim))
- (function prim prim stub (>. prim prim))
- (function prim prim stub (<=. prim prim))
- (function prim prim stub (>=. prim prim))))
- (module-defn(M_string) module_coercion.ml(34):1204-1249
- (makeblock 0 (function prim stub (array.length[addr] prim))
- (function prim prim stub
- (array.get[addr] prim prim))
- (function prim prim stub
- (array.unsafe_get[addr] prim prim))
- (function prim prim prim stub
- (array.set[addr] prim prim prim))
- (function prim prim prim stub
- (array.unsafe_set[addr] prim prim prim))
- (function prim prim stub
- (caml_string_compare prim prim))
- (function prim prim stub
- (caml_string_equal prim prim))
- (function prim prim stub
- (caml_string_notequal prim prim))
- (function prim prim stub
- (caml_string_lessthan prim prim))
- (function prim prim stub
- (caml_string_greaterthan prim prim))
- (function prim prim stub
- (caml_string_lessequal prim prim))
- (function prim prim stub
- (caml_string_greaterequal prim prim))))
- (module-defn(M_int32/1104) module_coercion.ml(35):1252-1295
- (makeblock 0 (function prim stub (array.length[addr] prim))
- (function prim prim stub
- (array.get[addr] prim prim))
- (function prim prim stub
- (array.unsafe_get[addr] prim prim))
- (function prim prim prim stub
- (array.set[addr] prim prim prim))
- (function prim prim prim stub
- (array.unsafe_set[addr] prim prim prim))
- (function prim prim stub
- (caml_int32_compare prim prim))
- (function prim prim stub (Int32.== prim prim))
- (function prim prim stub (Int32.!= prim prim))
- (function prim prim stub (Int32.< prim prim))
- (function prim prim stub (Int32.> prim prim))
- (function prim prim stub (Int32.<= prim prim))
- (function prim prim stub (Int32.>= prim prim))))
- (module-defn(M_int64/1129) module_coercion.ml(36):1298-1341
- (makeblock 0 (function prim stub (array.length[addr] prim))
- (function prim prim stub
- (array.get[addr] prim prim))
- (function prim prim stub
- (array.unsafe_get[addr] prim prim))
- (function prim prim prim stub
- (array.set[addr] prim prim prim))
- (function prim prim prim stub
- (array.unsafe_set[addr] prim prim prim))
- (function prim prim stub
- (caml_int64_compare prim prim))
- (function prim prim stub (Int64.== prim prim))
- (function prim prim stub (Int64.!= prim prim))
- (function prim prim stub (Int64.< prim prim))
- (function prim prim stub (Int64.> prim prim))
- (function prim prim stub (Int64.<= prim prim))
- (function prim prim stub (Int64.>= prim prim))))
- (module-defn(M_nativeint) module_coercion.ml(37):1344-1395
- (makeblock 0 (function prim stub (array.length[addr] prim))
- (function prim prim stub
- (array.get[addr] prim prim))
- (function prim prim stub
- (array.unsafe_get[addr] prim prim))
- (function prim prim prim stub
- (array.set[addr] prim prim prim))
- (function prim prim prim stub
- (array.unsafe_set[addr] prim prim prim))
- (function prim prim stub
- (caml_nativeint_compare prim prim))
- (function prim prim stub
- (Nativeint.== prim prim))
- (function prim prim stub
- (Nativeint.!= prim prim))
- (function prim prim stub
- (Nativeint.< prim prim))
- (function prim prim stub
- (Nativeint.> prim prim))
- (function prim prim stub
- (Nativeint.<= prim prim))
- (function prim prim stub
- (Nativeint.>= prim prim)))))))
+++ /dev/null
-(setglobal Module_coercion!
- (let
- (M = (module-defn(M) module_coercion.ml(1):0-699 (makeblock 0)))
- (makeblock 0 M
- (module-defn(M_int) module_coercion.ml(32):1116-1155
- (makeblock 0 (function prim stub (array.length[int] prim))
- (function prim prim stub
- (array.get[int] prim prim))
- (function prim prim stub
- (array.unsafe_get[int] prim prim))
- (function prim prim prim stub
- (array.set[int] prim prim prim))
- (function prim prim prim stub
- (array.unsafe_set[int] prim prim prim))
- (function prim prim stub
- (caml_int_compare prim prim))
- (function prim prim stub (== prim prim))
- (function prim prim stub (!= prim prim))
- (function prim prim stub (< prim prim))
- (function prim prim stub (> prim prim))
- (function prim prim stub (<= prim prim))
- (function prim prim stub (>= prim prim))))
- (module-defn(M_float) module_coercion.ml(33):1158-1201
- (makeblock 0 (function prim stub (array.length[addr] prim))
- (function prim prim stub
- (array.get[addr] prim prim))
- (function prim prim stub
- (array.unsafe_get[addr] prim prim))
- (function prim prim prim stub
- (array.set[addr] prim prim prim))
- (function prim prim prim stub
- (array.unsafe_set[addr] prim prim prim))
- (function prim prim stub
- (caml_float_compare prim prim))
- (function prim prim stub (==. prim prim))
- (function prim prim stub (!=. prim prim))
- (function prim prim stub (<. prim prim))
- (function prim prim stub (>. prim prim))
- (function prim prim stub (<=. prim prim))
- (function prim prim stub (>=. prim prim))))
- (module-defn(M_string) module_coercion.ml(34):1204-1249
- (makeblock 0 (function prim stub (array.length[addr] prim))
- (function prim prim stub
- (array.get[addr] prim prim))
- (function prim prim stub
- (array.unsafe_get[addr] prim prim))
- (function prim prim prim stub
- (array.set[addr] prim prim prim))
- (function prim prim prim stub
- (array.unsafe_set[addr] prim prim prim))
- (function prim prim stub
- (caml_string_compare prim prim))
- (function prim prim stub
- (caml_string_equal prim prim))
- (function prim prim stub
- (caml_string_notequal prim prim))
- (function prim prim stub
- (caml_string_lessthan prim prim))
- (function prim prim stub
- (caml_string_greaterthan prim prim))
- (function prim prim stub
- (caml_string_lessequal prim prim))
- (function prim prim stub
- (caml_string_greaterequal prim prim))))
- (module-defn(M_int32/1104) module_coercion.ml(35):1252-1295
- (makeblock 0 (function prim stub (array.length[addr] prim))
- (function prim prim stub
- (array.get[addr] prim prim))
- (function prim prim stub
- (array.unsafe_get[addr] prim prim))
- (function prim prim prim stub
- (array.set[addr] prim prim prim))
- (function prim prim prim stub
- (array.unsafe_set[addr] prim prim prim))
- (function prim prim stub
- (caml_int32_compare prim prim))
- (function prim prim stub (Int32.== prim prim))
- (function prim prim stub (Int32.!= prim prim))
- (function prim prim stub (Int32.< prim prim))
- (function prim prim stub (Int32.> prim prim))
- (function prim prim stub (Int32.<= prim prim))
- (function prim prim stub (Int32.>= prim prim))))
- (module-defn(M_int64/1129) module_coercion.ml(36):1298-1341
- (makeblock 0 (function prim stub (array.length[addr] prim))
- (function prim prim stub
- (array.get[addr] prim prim))
- (function prim prim stub
- (array.unsafe_get[addr] prim prim))
- (function prim prim prim stub
- (array.set[addr] prim prim prim))
- (function prim prim prim stub
- (array.unsafe_set[addr] prim prim prim))
- (function prim prim stub
- (caml_int64_compare prim prim))
- (function prim prim stub (Int64.== prim prim))
- (function prim prim stub (Int64.!= prim prim))
- (function prim prim stub (Int64.< prim prim))
- (function prim prim stub (Int64.> prim prim))
- (function prim prim stub (Int64.<= prim prim))
- (function prim prim stub (Int64.>= prim prim))))
- (module-defn(M_nativeint) module_coercion.ml(37):1344-1395
- (makeblock 0 (function prim stub (array.length[addr] prim))
- (function prim prim stub
- (array.get[addr] prim prim))
- (function prim prim stub
- (array.unsafe_get[addr] prim prim))
- (function prim prim prim stub
- (array.set[addr] prim prim prim))
- (function prim prim prim stub
- (array.unsafe_set[addr] prim prim prim))
- (function prim prim stub
- (caml_nativeint_compare prim prim))
- (function prim prim stub
- (Nativeint.== prim prim))
- (function prim prim stub
- (Nativeint.!= prim prim))
- (function prim prim stub
- (Nativeint.< prim prim))
- (function prim prim stub
- (Nativeint.> prim prim))
- (function prim prim stub
- (Nativeint.<= prim prim))
- (function prim prim stub
- (Nativeint.>= prim prim)))))))
--- /dev/null
+array_spec.ml
+comparison_table.ml
+module_coercion.ml
+ref_spec.ml
+locs.ml
--- /dev/null
+(setglobal Ref_spec!
+ (let
+ (int_ref = (makemutable 0 (int) 1)
+ var_ref = (makemutable 0 65a)
+ vargen_ref = (makemutable 0 65a)
+ cst_ref = (makemutable 0 0a)
+ gen_ref = (makemutable 0 0a)
+ flt_ref = (makemutable 0 (float) 0.))
+ (seq (setfield_imm 0 int_ref 2) (setfield_imm 0 var_ref 66a)
+ (setfield_ptr 0 vargen_ref [0: 66 0]) (setfield_ptr 0 vargen_ref 67a)
+ (setfield_imm 0 cst_ref 1a) (setfield_ptr 0 gen_ref [0: "foo"])
+ (setfield_ptr 0 gen_ref 0a) (setfield_ptr 0 flt_ref 1.)
+ (let
+ (int_rec = (makemutable 0 (*,int) 0a 1)
+ var_rec = (makemutable 0 0a 65a)
+ vargen_rec = (makemutable 0 0a 65a)
+ cst_rec = (makemutable 0 0a 0a)
+ gen_rec = (makemutable 0 0a 0a)
+ flt_rec = (makemutable 0 (*,float) 0a 0.)
+ flt_rec' = (makearray[float] 0. 0.))
+ (seq (setfield_imm 1 int_rec 2) (setfield_imm 1 var_rec 66a)
+ (setfield_ptr 1 vargen_rec [0: 66 0])
+ (setfield_ptr 1 vargen_rec 67a) (setfield_imm 1 cst_rec 1a)
+ (setfield_ptr 1 gen_rec [0: "foo"]) (setfield_ptr 1 gen_rec 0a)
+ (setfield_ptr 1 flt_rec 1.) (setfloatfield 1 flt_rec' 1.)
+ (let
+ (set_open_poly = (function r y (setfield_ptr 0 r y))
+ set_open_poly = (function r y (setfield_imm 0 r y))
+ set_open_poly = (function r y (setfield_imm 0 r y))
+ set_open_poly = (function r y (setfield_imm 0 r y))
+ set_open_poly = (function r y (setfield_ptr 0 r y))
+ set_open_poly = (function r y (setfield_ptr 0 r y))
+ set_open_poly = (function r y (setfield_ptr 0 r y))
+ set_open_poly = (function r y (setfield_ptr 0 r y)))
+ (makeblock 0 int_ref var_ref vargen_ref cst_ref gen_ref flt_ref
+ int_rec var_rec vargen_rec cst_rec gen_rec flt_rec flt_rec'
+ set_open_poly)))))))
+(* TEST
+ * setup-ocamlc.byte-build-env
+ ** ocamlc.byte
+ flags = "-dlambda -dno-unique-ids"
+ *** check-ocamlc.byte-output
+*)
+
type 'a custom_rec = { x : unit; mutable y : 'a }
type float_rec = { w : float; mutable z : float }
+++ /dev/null
-(setglobal Ref_spec!
- (let
- (int_ref = (makemutable 0 (int) 1)
- var_ref = (makemutable 0 65a)
- vargen_ref = (makemutable 0 65a)
- cst_ref = (makemutable 0 0a)
- gen_ref = (makemutable 0 0a)
- flt_ref = (makemutable 0 (float) 0.))
- (seq (setfield_imm 0 int_ref 2) (setfield_imm 0 var_ref 66a)
- (setfield_ptr 0 vargen_ref [0: 66 0])
- (setfield_ptr 0 vargen_ref 67a) (setfield_imm 0 cst_ref 1a)
- (setfield_ptr 0 gen_ref [0: "foo"])
- (setfield_ptr 0 gen_ref 0a) (setfield_ptr 0 flt_ref 1.)
- (let
- (int_rec = (makemutable 0 (*,int) 0a 1)
- var_rec = (makemutable 0 0a 65a)
- vargen_rec = (makemutable 0 0a 65a)
- cst_rec = (makemutable 0 0a 0a)
- gen_rec = (makemutable 0 0a 0a)
- flt_rec = (makemutable 0 (*,float) 0a 0.)
- flt_rec' = (makearray[float] 0. 0.))
- (seq (setfield_imm 1 int_rec 2)
- (setfield_imm 1 var_rec 66a)
- (setfield_ptr 1 vargen_rec [0: 66 0])
- (setfield_ptr 1 vargen_rec 67a)
- (setfield_imm 1 cst_rec 1a)
- (setfield_ptr 1 gen_rec [0: "foo"])
- (setfield_ptr 1 gen_rec 0a) (setfield_ptr 1 flt_rec 1.)
- (setfloatfield 1 flt_rec' 1.)
- (let
- (set_open_poly =
- (function r y (setfield_ptr 0 r y))
- set_open_poly =
- (function r y (setfield_imm 0 r y))
- set_open_poly =
- (function r y (setfield_imm 0 r y))
- set_open_poly =
- (function r y (setfield_imm 0 r y))
- set_open_poly =
- (function r y (setfield_ptr 0 r y))
- set_open_poly =
- (function r y (setfield_ptr 0 r y))
- set_open_poly =
- (function r y (setfield_ptr 0 r y))
- set_open_poly =
- (function r y (setfield_ptr 0 r y)))
- (makeblock 0 int_ref var_ref vargen_ref
- cst_ref gen_ref flt_ref int_rec
- var_rec vargen_rec cst_rec gen_rec
- flt_rec flt_rec' set_open_poly)))))))
--- /dev/null
+unit_fun_hints.ml
+type_expected_explanation.ml
--- /dev/null
+(* TEST
+ flags = "-strict-sequence"
+ * expect
+*)
+
+if 3 then ();;
+
+[%%expect{|
+Line _, characters 3-4:
+ if 3 then ();;
+ ^
+Error: This expression has type int but an expression was expected of type
+ bool
+ because it is in the condition of an if-statement
+|}];;
+
+fun b -> if true then (print_int b) else (if b then ());;
+
+[%%expect{|
+Line _, characters 45-46:
+ fun b -> if true then (print_int b) else (if b then ());;
+ ^
+Error: This expression has type int but an expression was expected of type
+ bool
+ because it is in the condition of an if-statement
+|}];;
+
+(* Left-to-right bias is still there: if we swap the branches, the new error
+ message does not show up because of propagation order. *)
+fun b -> if true then (if b then ()) else (print_int b);;
+
+[%%expect{|
+Line _, characters 53-54:
+ fun b -> if true then (if b then ()) else (print_int b);;
+ ^
+Error: This expression has type bool but an expression was expected of type
+ int
+|}];;
+
+if (let x = 3 in x) then ();;
+
+[%%expect{|
+Line _, characters 17-18:
+ if (let x = 3 in x) then ();;
+ ^
+Error: This expression has type int but an expression was expected of type
+ bool
+ because it is in the condition of an if-statement
+|}];;
+
+if (if true then 3 else 4) then ();;
+
+[%%expect{|
+Line _, characters 17-18:
+ if (if true then 3 else 4) then ();;
+ ^
+Error: This expression has type int but an expression was expected of type
+ bool
+ because it is in the condition of an if-statement
+|}];;
+
+if true then 3;;
+
+[%%expect{|
+Line _, characters 13-14:
+ if true then 3;;
+ ^
+Error: This expression has type int but an expression was expected of type
+ unit
+ because it is in the result of a conditional with no else branch
+|}];;
+
+if (fun x -> x) then ();;
+
+[%%expect{|
+Line _, characters 3-15:
+ if (fun x -> x) then ();;
+ ^^^^^^^^^^^^
+Error: This expression should not be a function, the expected type is
+bool
+because it is in the condition of an if-statement
+|}];;
+
+while 42 do () done;;
+
+[%%expect{|
+Line _, characters 6-8:
+ while 42 do () done;;
+ ^^
+Error: This expression has type int but an expression was expected of type
+ bool
+ because it is in the condition of a while-loop
+|}];;
+
+(* -strict-sequence is required for this test to fail, otherwise only a warning
+ is produced *)
+while true do (if true then 3 else 4) done;;
+
+[%%expect{|
+Line _, characters 14-37:
+ while true do (if true then 3 else 4) done;;
+ ^^^^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type int but an expression was expected of type
+ unit
+ because it is in the body of a while-loop
+|}];;
+
+for i = 3. to 4 do () done;;
+
+[%%expect{|
+Line _, characters 8-10:
+ for i = 3. to 4 do () done;;
+ ^^
+Error: This expression has type float but an expression was expected of type
+ int
+ because it is in a for-loop start index
+|}];;
+
+for i = 3 to 4. do () done;;
+
+[%%expect{|
+Line _, characters 13-15:
+ for i = 3 to 4. do () done;;
+ ^^
+Error: This expression has type float but an expression was expected of type
+ int
+ because it is in a for-loop stop index
+|}];;
+
+(* -strict-sequence is required for this test to fail, otherwise only a warning
+ is produced *)
+for i = 0 to 0 do (if true then 3 else 4) done;;
+
+[%%expect{|
+Line _, characters 18-41:
+ for i = 0 to 0 do (if true then 3 else 4) done;;
+ ^^^^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type int but an expression was expected of type
+ unit
+ because it is in the body of a for-loop
+|}];;
+
+assert 12;;
+
+[%%expect{|
+Line _, characters 7-9:
+ assert 12;;
+ ^^
+Error: This expression has type int but an expression was expected of type
+ bool
+ because it is in the condition of an assertion
+|}];;
+
+(* -strict-sequence is also required for this test to fail *)
+(let x = 3 in x+1); ();;
+
+[%%expect{|
+Line _, characters 0-18:
+ (let x = 3 in x+1); ();;
+ ^^^^^^^^^^^^^^^^^^
+Error: This expression has type int but an expression was expected of type
+ unit
+ because it is in the left-hand side of a sequence
+|}];;
+
+let ordered_list_with x y =
+ if x <= y then [x;y]
+ else if x > y then [y;x]
+
+[%%expect{|
+Line _, characters 22-26:
+ else if x > y then [y;x]
+ ^^^^
+Error: This variant expression is expected to have type unit
+ because it is in the result of a conditional with no else branch
+ The constructor :: does not belong to type unit
+|}];;
--- /dev/null
+(* TEST
+ flags = "-strict-sequence"
+ * expect
+*)
+
+let g f = f ()
+let _ = g 3;; (* missing `fun () ->' *)
+
+[%%expect{|
+val g : (unit -> 'a) -> 'a = <fun>
+Line _, characters 10-11:
+ let _ = g 3;; (* missing `fun () ->' *)
+ ^
+Error: This expression has type int but an expression was expected of type
+ unit -> 'a
+ Hint: Did you forget to wrap the expression using `fun () ->'?
+|}];;
+
+
+let _ =
+ print_int 3;
+ print_newline; (* missing unit argument *)
+ print_int 5;;
+
+(* We use -strict-sequence for this test: otherwise only a warning is produced
+ about print_newline not being of type unit *)
+[%%expect{|
+Line _, characters 3-16:
+ print_newline; (* missing unit argument *)
+ ^^^^^^^^^^^^^
+Error: This expression has type unit -> unit
+ but an expression was expected of type unit
+ because it is in the left-hand side of a sequence
+ Hint: Did you forget to provide `()' as argument?
+|}];;
+
+let x = read_int in (* missing unit argument *)
+print_int x;;
+
+[%%expect{|
+Line _, characters 10-11:
+ print_int x;;
+ ^
+Error: This expression has type unit -> int
+ but an expression was expected of type int
+ Hint: Did you forget to provide `()' as argument?
+|}];;
+
+let g f =
+ let _ = f () in
+ f = 3;;
+
+[%%expect{|
+Line _, characters 6-7:
+ f = 3;;
+ ^
+Error: This expression has type int but an expression was expected of type
+ unit -> 'a
+ Hint: Did you forget to wrap the expression using `fun () ->'?
+|}];;
+
+let g f =
+ let _ = f () in
+ 3 = f;;
+
+[%%expect{|
+Line _, characters 6-7:
+ 3 = f;;
+ ^
+Error: This expression has type unit -> 'a
+ but an expression was expected of type int
+ Hint: Did you forget to provide `()' as argument?
+|}]
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.expect
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * expect
+*)
+
[@@@ocaml.warning "+3"];;
module X: sig
end;;
[%%expect{|
Line _, characters 9-10:
+ val x: t [@@ocaml.deprecated]
+ ^
Warning 3: deprecated: t
module X : sig type t type s type u val x : t end
|}]
;;
[%%expect{|
Line _, characters 9-12:
+ type t = X.t
+ ^^^
Warning 3: deprecated: X.t
type t = X.t
|}]
;;
[%%expect{|
Line _, characters 8-11:
+ let x = X.x
+ ^^^
Warning 3: deprecated: X.x
val x : X.t = <abstr>
|}]
;;
[%%expect{|
Line _, characters 9-12:
+ type t = X.t * X.s
+ ^^^
Warning 3: deprecated: X.t
Line _, characters 15-18:
+ type t = X.t * X.s
+ ^^^
Warning 3: deprecated: X.s
type t = X.t * X.s
|}]
;;
[%%expect{|
Line _, characters 9-12:
+ and t2 = X.s
+ ^^^
Warning 3: deprecated: X.s
type t1 = X.t
and t2 = X.s
;;
[%%expect{|
Line _, characters 14-15:
+ type t = A of t [@@ocaml.deprecated]
+ ^
Warning 3: deprecated: t
type t = A of t
|}]
;;
[%%expect{|
Line _, characters 39-42:
+ type t = (X.t [@ocaml.warning "-3"]) * X.s
+ ^^^
Warning 3: deprecated: X.s
type t = X.t * X.s
|}]
;;
[%%expect{|
Line _, characters 22-25:
+ let _ = function (_ : X.t) -> ()
+ ^^^
Warning 3: deprecated: X.t
- : X.t -> unit = <fun>
|}]
;;
[%%expect{|
Line _, characters 26-29:
+ module M = struct let x = X.x end
+ ^^^
Warning 3: deprecated: X.x
module M : sig val x : X.t end
|}]
module rec M : sig val x: X.t end = struct let x = X.x end
[%%expect{|
Line _, characters 26-29:
+ module rec M : sig val x: X.t end = struct let x = X.x end
+ ^^^
Warning 3: deprecated: X.t
Line _, characters 51-54:
+ module rec M : sig val x: X.t end = struct let x = X.x end
+ ^^^
Warning 3: deprecated: X.x
module rec M : sig val x : X.t end
|}]
struct let x = X.x end
[%%expect{|
Line _, characters 17-20:
+ struct let x = X.x end
+ ^^^
Warning 3: deprecated: X.x
module rec M : sig val x : X.t end
|}]
;;
[%%expect{|
Line _, characters 29-32:
+ module type S = sig type t = X.t end
+ ^^^
Warning 3: deprecated: X.t
module type S = sig type t = X.t end
|}]
;;
[%%expect{|
Line _, characters 28-31:
+ class c = object method x = X.x end
+ ^^^
Warning 3: deprecated: X.x
class c : object method x : X.t end
|}]
;;
[%%expect{|
Line _, characters 33-36:
+ class type c = object method x : X.t end
+ ^^^
Warning 3: deprecated: X.t
class type c = object method x : X.t end
|}]
;;
[%%expect{|
Line _, characters 22-25:
+ external foo: unit -> X.t = "foo"
+ ^^^
Warning 3: deprecated: X.t
external foo : unit -> X.t = "foo"
|}]
;;
[%%expect{|
Line _, characters 0-3:
+ X.x
+ ^^^
Warning 3: deprecated: X.x
- : X.t = <abstr>
|}]
[%%expect{|
module D : sig end
Line _, characters 5-6:
+ open D
+ ^
Warning 3: deprecated: module D
|}]
;;
[%%expect{|
Line _, characters 8-9:
+ include D
+ ^
Warning 3: deprecated: module D
|}]
;;
[%%expect{|
Line _, characters 9-12:
+ | A of X.t
+ ^^^
Warning 3: deprecated: X.t
type ext += A of X.t | B of X.s | C of X.u
|}]
;;
[%%expect{|
Line _, characters 17-20:
+ exception Foo of X.t
+ ^^^
Warning 3: deprecated: X.t
exception Foo of X.t
|}]
;;
[%%expect{|
Line _, characters 9-12:
+ | A of X.t
+ ^^^
Warning 3: deprecated: X.t
type t = A of X.t | B of X.s | C of X.u
|}]
;;
[%%expect{|
Line _, characters 7-10:
+ a: X.t;
+ ^^^
Warning 3: deprecated: X.t
type t = { a : X.t; b : X.s; c : X.u; }
|}]
;;
[%%expect{|
Line _, characters 7-10:
+ a: X.t;
+ ^^^
Warning 3: deprecated: X.t
type t = < a : X.t; b : X.s; c : X.u >
|}]
;;
[%%expect{|
Line _, characters 10-13:
+ | `A of X.t
+ ^^^
Warning 3: deprecated: X.t
type t = [ `A of X.t | `B of X.s | `C of X.u ]
|}]
;;
[%%expect{|
Line _, characters 20-33:
+ [@@@ocaml.ppwarning "Pp warning!"]
+ ^^^^^^^^^^^^^
Warning 22: Pp warning!
|}]
;;
[%%expect{|
Line _, characters 24-39:
+ [@@ocaml.ppwarning "Pp warning 2!"]
+ ^^^^^^^^^^^^^^^
Warning 22: Pp warning 2!
Line _, characters 29-44:
+ let x = () [@ocaml.ppwarning "Pp warning 1!"]
+ ^^^^^^^^^^^^^^^
Warning 22: Pp warning 1!
val x : unit = ()
|}]
;;
[%%expect{|
Line _, characters 22-35:
+ [@ocaml.ppwarning "Pp warning!"]
+ ^^^^^^^^^^^^^
Warning 22: Pp warning!
type t = unit
|}]
;;
[%%expect{|
Line _, characters 22-36:
+ [@@@ocaml.ppwarning "Pp warning2!"]
+ ^^^^^^^^^^^^^^
Warning 22: Pp warning2!
module X : sig end
|}]
;;
[%%expect{|
Line _, characters 93-108:
+ let x = ((() [@ocaml.ppwarning "Pp warning 1!"]) [@ocaml.warning "-22"]) [@ocaml.ppwarning "Pp warning 2!"]
+ ^^^^^^^^^^^^^^^
Warning 22: Pp warning 2!
val x : unit = ()
|}]
;;
[%%expect{|
Line _, characters 21-36:
+ [@@ocaml.ppwarning "Pp warning 3!"]
+ ^^^^^^^^^^^^^^^
Warning 22: Pp warning 3!
Line _, characters 96-111:
+ type t = ((unit [@ocaml.ppwarning "Pp warning 1!"]) [@ocaml.warning "-22"]) [@ocaml.ppwarning "Pp warning 2!"]
+ ^^^^^^^^^^^^^^^
Warning 22: Pp warning 2!
type t = unit
|}]
;;
[%%expect{|
Line _, characters 25-29:
+ let ([][@ocaml.ppwarning "XX"]) = []
+ ^^^^
Warning 22: XX
Line _, characters 4-31:
+ let ([][@ocaml.ppwarning "XX"]) = []
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
_::_
--- /dev/null
+deprecated.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * toplevel
+*)
type t = ..;;
type t += A;;
+++ /dev/null
-
-# type t = ..
-# type t += A
-# - : extension_constructor = <abstr>
-# - : extension_constructor = <abstr>
-# module M : sig type extension_constructor = int end
-# # Characters 2-28:
- ([%extension_constructor A] : extension_constructor);;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This expression has type extension_constructor
- but an expression was expected of type M.extension_constructor = int
-#
--- /dev/null
+type t = ..
+type t += A
+- : extension_constructor = <abstr>
+- : extension_constructor = <abstr>
+module M : sig type extension_constructor = int end
+Characters 2-28:
+ ([%extension_constructor A] : extension_constructor);;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type extension_constructor
+ but an expression was expected of type M.extension_constructor = int
+
+++ /dev/null
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * toplevel
+*)
+
(* Ignore OCAMLRUNPARAM=b to be reproducible *)
Printexc.record_backtrace false;;
+++ /dev/null
-
-# - : unit = ()
-# type 'b class_name = .. constraint 'b = < cast : 'a. 'a name -> 'a; .. >
-and 'a name =
- Class : 'a class_name -> (< cast : 'a0. 'a0 name -> 'a0; .. > as 'a) name
-# exception Bad_cast
-# class type castable = object method cast : 'a name -> 'a end
-# class type foo_t = object method cast : 'a name -> 'a method foo : string end
-# type 'b class_name += Foo : foo_t class_name
-# class foo : foo_t
-# class type bar_t =
- object
- method bar : string
- method cast : 'a name -> 'a
- method foo : string
- end
-# type 'b class_name += Bar : bar_t class_name
-# class bar : bar_t
-# val clist : castable list ref = {contents = []}
-# val push_castable : #castable -> unit = <fun>
-# val pop_castable : unit -> castable = <fun>
-# - : unit = ()
-# - : unit = ()
-# - : unit = ()
-# val c1 : castable = <obj>
-# val c2 : castable = <obj>
-# val c3 : castable = <obj>
-# val f1 : foo = <obj>
-# val f2 : foo = <obj>
-# val f3 : foo = <obj>
-# Exception: Bad_cast.
-# val b2 : bar = <obj>
-# Exception: Bad_cast.
-#
--- /dev/null
+- : unit = ()
+type 'b class_name = .. constraint 'b = < cast : 'a. 'a name -> 'a; .. >
+and 'a name =
+ Class : 'a class_name -> (< cast : 'a0. 'a0 name -> 'a0; .. > as 'a) name
+exception Bad_cast
+class type castable = object method cast : 'a name -> 'a end
+class type foo_t = object method cast : 'a name -> 'a method foo : string end
+type 'b class_name += Foo : foo_t class_name
+class foo : foo_t
+class type bar_t =
+ object
+ method bar : string
+ method cast : 'a name -> 'a
+ method foo : string
+ end
+type 'b class_name += Bar : bar_t class_name
+class bar : bar_t
+val clist : castable list ref = {contents = []}
+val push_castable : #castable -> unit = <fun>
+val pop_castable : unit -> castable = <fun>
+- : unit = ()
+- : unit = ()
+- : unit = ()
+val c1 : castable = <obj>
+val c2 : castable = <obj>
+val c3 : castable = <obj>
+val f1 : foo = <obj>
+val f2 : foo = <obj>
+val f3 : foo = <obj>
+Exception: Bad_cast.
+val b2 : bar = <obj>
+Exception: Bad_cast.
+
+(* TEST
+ * toplevel
+*)
+
(* Ignore OCAMLRUNPARAM=b to be reproducible *)
Printexc.record_backtrace false;;
+++ /dev/null
-
-# - : unit = ()
-# type foo = ..
-# type foo += A | B of int
-# val is_a : foo -> bool = <fun>
-# type foo
-# Characters 1-21:
- type foo += A of int (* Error type is not open *)
- ^^^^^^^^^^^^^^^^^^^^
-Error: Type definition foo is not extensible
-# type foo = private ..
-# Characters 13-21:
- type foo += A of int (* Error type is private *)
- ^^^^^^^^
-Error: Cannot extend private type definition foo
-# type 'a foo = ..
-# Characters 1-30:
- type ('a, 'b) foo += A of int (* Error: type parameter mismatch *)
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This extension does not match the definition of type foo
- They have different arities.
-# module type S = sig type foo = private .. type foo += A of float end
-# Characters 73-95:
- type foo += B of float (* Error: foo does not have an extensible type *)
- ^^^^^^^^^^^^^^^^^^^^^^
-Error: Type definition foo is not extensible
-# type foo = ..
-# module M :
- sig
- type foo += A of int | B of string
- type foo += C of int | D of float
-
- end
-# module type S =
- sig
- type foo += B of string | C of int
- type foo += D of float
- type foo += A of int
- end
-# module M_S : S
-# type 'a foo = ..
-# type _ foo += A : int -> int foo | B : int foo
-# val get_num : 'a foo -> 'a -> 'a option = <fun>
-# type 'a foo = .. constraint 'a = [> `Var ]
-# type 'a foo += A of 'a
-# Characters 11-12:
- let a = A 9 (* ERROR: Constraints not met *)
- ^
-Error: This expression has type int but an expression was expected of type
- [> `Var ]
-# Characters 20-23:
- type 'a foo += B : int foo (* ERROR: Constraints not met *)
- ^^^
-Error: This type int should be an instance of type [> `Var ]
-# type foo = ..
-# module M : sig type foo += A of int end
-# val a1 : foo = M.A 10
-# module type S = sig type foo += private A of int end
-# module M_S : S
-# val is_s : foo -> bool = <fun>
-# Characters 10-18:
- let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *)
- ^^^^^^^^
-Error: Cannot create values of the private type foo
-# type foo = ..
-# module M : sig type foo += A1 of int end
-# type foo += A2 of int
-# type bar = ..
-# Characters 18-22:
- type bar += A3 = M.A1 (* Error: rebind wrong type *)
- ^^^^
-Error: The constructor M.A1 has type foo but was expected to be of type bar
-# module M : sig type foo += private B1 of int end
-# type foo += private B2 of int
-# Characters 18-22:
- type foo += B3 = M.B1 (* Error: rebind private extension *)
- ^^^^
-Error: The constructor M.B1 is private
-# Characters 17-24:
- type foo += C = Unknown (* Error: unbound extension *)
- ^^^^^^^
-Error: Unbound constructor Unknown
-# module M : sig type foo = private .. type foo += A1 of int end
-type M.foo += A2 of int
-type 'a foo = ..
-# type 'a foo1 = 'a foo = ..
-# type 'a foo2 = 'a foo = ..
-# type 'a foo1 += A of int | B of 'a | C : int foo1
-# type 'a foo2 += D of int | E of 'a | F : int foo2
-# type +'a foo = ..
-# type 'a foo += A of (int -> 'a)
-# Characters 1-32:
- type 'a foo += B of ('a -> int)
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, expected parameter variances are not satisfied.
- The 1st type parameter was expected to be covariant,
- but it is injective contravariant.
-# Characters 1-40:
- type _ foo += C : ('a -> int) -> 'a foo
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, expected parameter variances are not satisfied.
- The 1st type parameter was expected to be covariant,
- but it is injective contravariant.
-# type 'a bar = ..
-# Characters 1-33:
- type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *)
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This extension does not match the definition of type bar
- Their variances do not agree.
-# module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end
-# module M :
- sig exception Bar : 'a list -> exn exception Foo of int * float end
-# exception Foo of int * float
-# exception Bar : 'a list -> exn
-# module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end
-# type foo = ..
-# type foo += Foo of int * int option | Bar of int option
-# val x : foo * foo = (Foo (3, Some 4), Bar (Some 5))
-# type foo += Foo of string
-# val y : foo * foo = (<extension>, Bar (Some 5))
-# exception Foo of int * int option
-# exception Bar of int option
-# val x : exn * exn = (Foo (3, Some 4), Bar (Some 5))
-# type foo += Foo of string
-# val y : exn * exn = (Foo (3, _), Bar (Some 5))
-# type foo = ..
-# type foo += Foo | Bar of int
-# val extension_name : 'a -> string = <fun>
-# val extension_id : 'a -> int = <fun>
-# val n1 : string = "Foo"
-# val n2 : string = "Bar"
-# val t : bool = true
-# val f : bool = false
-# val is_foo : 'a -> bool = <fun>
-type foo += Foo
-# val f : bool = false
-# Exception: Invalid_argument "Obj.extension_constructor".
-# Exception: Invalid_argument "Obj.extension_constructor".
-#
--- /dev/null
+- : unit = ()
+type foo = ..
+type foo += A | B of int
+val is_a : foo -> bool = <fun>
+type foo
+Characters 1-21:
+ type foo += A of int (* Error type is not open *)
+ ^^^^^^^^^^^^^^^^^^^^
+Error: Type definition foo is not extensible
+type foo = private ..
+Characters 13-21:
+ type foo += A of int (* Error type is private *)
+ ^^^^^^^^
+Error: Cannot extend private type definition foo
+type 'a foo = ..
+Characters 1-30:
+ type ('a, 'b) foo += A of int (* Error: type parameter mismatch *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This extension does not match the definition of type foo
+ They have different arities.
+module type S = sig type foo = private .. type foo += A of float end
+Characters 73-95:
+ type foo += B of float (* Error: foo does not have an extensible type *)
+ ^^^^^^^^^^^^^^^^^^^^^^
+Error: Type definition foo is not extensible
+type foo = ..
+module M :
+ sig
+ type foo += A of int | B of string
+ type foo += C of int | D of float
+
+ end
+module type S =
+ sig
+ type foo += B of string | C of int
+ type foo += D of float
+ type foo += A of int
+ end
+module M_S : S
+type 'a foo = ..
+type _ foo += A : int -> int foo | B : int foo
+val get_num : 'a foo -> 'a -> 'a option = <fun>
+type 'a foo = .. constraint 'a = [> `Var ]
+type 'a foo += A of 'a
+Characters 11-12:
+ let a = A 9 (* ERROR: Constraints not met *)
+ ^
+Error: This expression has type int but an expression was expected of type
+ [> `Var ]
+Characters 20-23:
+ type 'a foo += B : int foo (* ERROR: Constraints not met *)
+ ^^^
+Error: This type int should be an instance of type [> `Var ]
+type foo = ..
+module M : sig type foo += A of int end
+val a1 : foo = M.A 10
+module type S = sig type foo += private A of int end
+module M_S : S
+val is_s : foo -> bool = <fun>
+Characters 10-18:
+ let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *)
+ ^^^^^^^^
+Error: Cannot create values of the private type foo
+type foo = ..
+module M : sig type foo += A1 of int end
+type foo += A2 of int
+type bar = ..
+Characters 18-22:
+ type bar += A3 = M.A1 (* Error: rebind wrong type *)
+ ^^^^
+Error: The constructor M.A1 has type foo but was expected to be of type bar
+module M : sig type foo += private B1 of int end
+type foo += private B2 of int
+Characters 18-22:
+ type foo += B3 = M.B1 (* Error: rebind private extension *)
+ ^^^^
+Error: The constructor M.B1 is private
+Characters 17-24:
+ type foo += C = Unknown (* Error: unbound extension *)
+ ^^^^^^^
+Error: Unbound constructor Unknown
+module M : sig type foo = private .. type foo += A1 of int end
+type M.foo += A2 of int
+type 'a foo = ..
+type 'a foo1 = 'a foo = ..
+type 'a foo2 = 'a foo = ..
+type 'a foo1 += A of int | B of 'a | C : int foo1
+type 'a foo2 += D of int | E of 'a | F : int foo2
+type +'a foo = ..
+type 'a foo += A of (int -> 'a)
+Characters 1-32:
+ type 'a foo += B of ('a -> int)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, expected parameter variances are not satisfied.
+ The 1st type parameter was expected to be covariant,
+ but it is injective contravariant.
+Characters 1-40:
+ type _ foo += C : ('a -> int) -> 'a foo
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, expected parameter variances are not satisfied.
+ The 1st type parameter was expected to be covariant,
+ but it is injective contravariant.
+type 'a bar = ..
+Characters 1-33:
+ type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This extension does not match the definition of type bar
+ Their variances do not agree.
+module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end
+module M :
+ sig exception Bar : 'a list -> exn exception Foo of int * float end
+exception Foo of int * float
+exception Bar : 'a list -> exn
+module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end
+type foo = ..
+type foo += Foo of int * int option | Bar of int option
+val x : foo * foo = (Foo (3, Some 4), Bar (Some 5))
+type foo += Foo of string
+val y : foo * foo = (<extension>, Bar (Some 5))
+exception Foo of int * int option
+exception Bar of int option
+val x : exn * exn = (Foo (3, Some 4), Bar (Some 5))
+type foo += Foo of string
+val y : exn * exn = (Foo (3, _), Bar (Some 5))
+type foo = ..
+type foo += Foo | Bar of int
+val extension_name : 'a -> string = <fun>
+val extension_id : 'a -> int = <fun>
+val n1 : string = "Foo"
+val n2 : string = "Bar"
+val t : bool = true
+val f : bool = false
+val is_foo : 'a -> bool = <fun>
+type foo += Foo
+val f : bool = false
+Exception: Invalid_argument "Obj.extension_constructor".
+Exception: Invalid_argument "Obj.extension_constructor".
+
+(* TEST
+ * toplevel
+*)
+
(* Typed names *)
module Msg : sig
+++ /dev/null
-
-# module Msg :
- sig
- type 'a tag = private ..
- type result = Result : 'a tag * 'a -> result
- val write : 'a tag -> 'a -> unit
- val read : unit -> result
- type 'a tag += Int : int tag
- module type Desc =
- sig
- type t
- val label : string
- val write : t -> string
- val read : string -> t
- end
- module Define : functor (D : Desc) -> sig type 'a tag += C : D.t tag end
- end
-# val write_int : int -> unit = <fun>
-# module StrM : sig type 'a Msg.tag += C : string Msg.tag end
-# type 'a Msg.tag += String : string Msg.tag
-# val write_string : string -> unit = <fun>
-# val read_one : unit -> unit = <fun>
-#
--- /dev/null
+module Msg :
+ sig
+ type 'a tag = private ..
+ type result = Result : 'a tag * 'a -> result
+ val write : 'a tag -> 'a -> unit
+ val read : unit -> result
+ type 'a tag += Int : int tag
+ module type Desc =
+ sig
+ type t
+ val label : string
+ val write : t -> string
+ val read : string -> t
+ end
+ module Define : functor (D : Desc) -> sig type 'a tag += C : D.t tag end
+ end
+val write_int : int -> unit = <fun>
+module StrM : sig type 'a Msg.tag += C : string Msg.tag end
+type 'a Msg.tag += String : string Msg.tag
+val write_string : string -> unit = <fun>
+val read_one : unit -> unit = <fun>
+
--- /dev/null
+cast.ml
+extensions.ml
+msg.ml
+open_types.ml
+(* TEST
+ * toplevel
+*)
+
type foo = ..
;;
+++ /dev/null
-
-# type foo = ..
-# type bar = foo = ..
-# type baz = foo = ..
-# type bar += Bar1 of int
-# type baz += Bar2 of int
-# module M : sig type bar += Foo of float end
-# module type S = sig type baz += Foo of float end
-# module M_S : S
-# type foo = ..
-# type bar = foo
-# Characters 1-23:
- type bar += Bar of int (* Error: type is not open *)
- ^^^^^^^^^^^^^^^^^^^^^^
-Error: Type definition bar is not extensible
-# Characters 1-20:
- type baz = bar = .. (* Error: type kinds don't match *)
- ^^^^^^^^^^^^^^^^^^^
-Error: This variant or record definition does not match that of type bar
- Their kinds differ.
-# type 'a foo = ..
-# Characters 1-32:
- type ('a, 'b) bar = 'a foo = .. (* Error: arrities do not match *)
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This variant or record definition does not match that of type 'a foo
- They have different arities.
-# type ('a, 'b) foo = ..
-# Characters 1-38:
- type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *)
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This variant or record definition does not match that of type
- ('a, 'a) foo
- Their constraints differ.
-# module M : sig type foo = .. end
-# module type S = sig type foo end
-# module M_S : S
-# Characters 1-20:
- type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *)
- ^^^^^^^^^^^^^^^^^^^
-Error: Type definition M_S.foo is not extensible
-# module M : sig type foo end
-# module type S = sig type foo = .. end
-# Characters 15-16:
- module M_S = (M : S) (* ERROR: Signatures are not compatible *)
- ^
-Error: Signature mismatch:
- Modules do not match: sig type foo = M.foo end is not included in S
- Type declarations do not match:
- type foo = M.foo
- is not included in
- type foo = ..
- Their kinds differ.
-# module M : sig type foo = .. end
-# module type S = sig type foo = private .. end
-# module M_S : S
-# Characters 17-20:
- type M_S.foo += Foo (* ERROR: Cannot extend a private extensible type *)
- ^^^
-Error: Cannot extend private type definition M_S.foo
-# module M : sig type foo = private .. end
-# module type S = sig type foo = .. end
-# Characters 15-16:
- module M_S = (M : S) (* ERROR: Signatures are not compatible *)
- ^
-Error: Signature mismatch:
- Modules do not match:
- sig type foo = M.foo = private .. end
- is not included in
- S
- Type declarations do not match:
- type foo = M.foo = private ..
- is not included in
- type foo = ..
- A private type would be revealed.
-# module M : sig type +'a foo = .. type 'a bar = 'a foo = .. end
-# module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end
-# Characters 15-16:
- module M_S = (M : S) (* ERROR: Signatures are not compatible *)
- ^
-Error: Signature mismatch:
- Modules do not match:
- sig type 'a foo = 'a M.foo = .. type 'a bar = 'a foo = .. end
- is not included in
- S
- Type declarations do not match:
- type 'a foo = 'a M.foo = ..
- is not included in
- type 'a foo = ..
- Their variances do not agree.
-# type exn2 = exn = ..
-# Characters 61-79:
- let f = function Foo -> ()
- ^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-*extension*
-Matching over values of extensible variant types (the *extension* above)
-must include a wild card pattern in order to be exhaustive.
-type foo = ..
-type foo += Foo
-val f : foo -> unit = <fun>
-# Characters 44-96:
- ........function
- | [Foo] -> 1
- | _::_::_ -> 3
- | [] -> 2
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-*extension*::[]
-Matching over values of extensible variant types (the *extension* above)
-must include a wild card pattern in order to be exhaustive.
-val f : foo list -> int = <fun>
-# type t = ..
-type t += IPair : (int * int) -> t
-# Characters 9-63:
- let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; (* warn *)
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-*extension*
-Matching over values of extensible variant types (the *extension* above)
-must include a wild card pattern in order to be exhaustive.
-val f : t -> string = <fun>
-#
--- /dev/null
+type foo = ..
+type bar = foo = ..
+type baz = foo = ..
+type bar += Bar1 of int
+type baz += Bar2 of int
+module M : sig type bar += Foo of float end
+module type S = sig type baz += Foo of float end
+module M_S : S
+type foo = ..
+type bar = foo
+Characters 1-23:
+ type bar += Bar of int (* Error: type is not open *)
+ ^^^^^^^^^^^^^^^^^^^^^^
+Error: Type definition bar is not extensible
+Characters 1-20:
+ type baz = bar = .. (* Error: type kinds don't match *)
+ ^^^^^^^^^^^^^^^^^^^
+Error: This variant or record definition does not match that of type bar
+ Their kinds differ.
+type 'a foo = ..
+Characters 1-32:
+ type ('a, 'b) bar = 'a foo = .. (* Error: arrities do not match *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This variant or record definition does not match that of type 'a foo
+ They have different arities.
+type ('a, 'b) foo = ..
+Characters 1-38:
+ type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This variant or record definition does not match that of type
+ ('a, 'a) foo
+ Their constraints differ.
+module M : sig type foo = .. end
+module type S = sig type foo end
+module M_S : S
+Characters 1-20:
+ type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *)
+ ^^^^^^^^^^^^^^^^^^^
+Error: Type definition M_S.foo is not extensible
+module M : sig type foo end
+module type S = sig type foo = .. end
+Characters 15-16:
+ module M_S = (M : S) (* ERROR: Signatures are not compatible *)
+ ^
+Error: Signature mismatch:
+ Modules do not match: sig type foo = M.foo end is not included in S
+ Type declarations do not match:
+ type foo = M.foo
+ is not included in
+ type foo = ..
+ Their kinds differ.
+module M : sig type foo = .. end
+module type S = sig type foo = private .. end
+module M_S : S
+Characters 17-20:
+ type M_S.foo += Foo (* ERROR: Cannot extend a private extensible type *)
+ ^^^
+Error: Cannot extend private type definition M_S.foo
+module M : sig type foo = private .. end
+module type S = sig type foo = .. end
+Characters 15-16:
+ module M_S = (M : S) (* ERROR: Signatures are not compatible *)
+ ^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type foo = M.foo = private .. end
+ is not included in
+ S
+ Type declarations do not match:
+ type foo = M.foo = private ..
+ is not included in
+ type foo = ..
+ A private type would be revealed.
+module M : sig type +'a foo = .. type 'a bar = 'a foo = .. end
+module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end
+Characters 15-16:
+ module M_S = (M : S) (* ERROR: Signatures are not compatible *)
+ ^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type 'a foo = 'a M.foo = .. type 'a bar = 'a foo = .. end
+ is not included in
+ S
+ Type declarations do not match:
+ type 'a foo = 'a M.foo = ..
+ is not included in
+ type 'a foo = ..
+ Their variances do not agree.
+type exn2 = exn = ..
+Characters 61-79:
+ let f = function Foo -> ()
+ ^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+*extension*
+Matching over values of extensible variant types (the *extension* above)
+must include a wild card pattern in order to be exhaustive.
+type foo = ..
+type foo += Foo
+val f : foo -> unit = <fun>
+Characters 44-96:
+ ........function
+ | [Foo] -> 1
+ | _::_::_ -> 3
+ | [] -> 2
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+*extension*::[]
+Matching over values of extensible variant types (the *extension* above)
+must include a wild card pattern in order to be exhaustive.
+val f : foo list -> int = <fun>
+type t = ..
+type t += IPair : (int * int) -> t
+Characters 9-63:
+ let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; (* warn *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+*extension*
+Matching over values of extensible variant types (the *extension* above)
+must include a wild card pattern in order to be exhaustive.
+val f : t -> string = <fun>
+
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-#MODULES=
-MAIN_MODULE=fstclassmod
-ADD_COMPFLAGS=-w A -warn-error A
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ flags = "-w A -warn-error A"
+*)
+
(* Example of algorithm parametrized with modules *)
let sort (type s) set l =
--- /dev/null
+fstclassmod.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.expect
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+(* TEST
+ * expect
+*)
+
+[@@@warning "-8-11-12"] (* reduce the noise. *)
+
+type ('a, 'b) eq = Refl : ('a, 'a) eq;;
+[%%expect{|
+type ('a, 'b) eq = Refl : ('a, 'a) eq
+|}];;
+
+let ret_e1 (type a b) (b : bool) (wit : (a, b) eq) (x : a) (y : b) =
+ match wit with
+ | Refl -> if b then x else y
+ | _ -> x
+;;
+[%%expect{|
+Line _, characters 29-30:
+ | Refl -> if b then x else y
+ ^
+Error: This expression has type b = a but an expression was expected of type
+ a
+ This instance of a is ambiguous:
+ it would escape the scope of its equation
+|}]
+
+let ret_e2 (type a b) (b : bool) (wit : (a, b) eq) (x : a) (y : b) =
+ match wit with
+ | Refl -> if b then x else y
+ | _ -> y
+;;
+[%%expect{|
+Line _, characters 29-30:
+ | Refl -> if b then x else y
+ ^
+Error: This expression has type b = a but an expression was expected of type
+ a
+ This instance of a is ambiguous:
+ it would escape the scope of its equation
+|}]
+
+let ret_ei1 (type a) (b : bool) (wit : (a, int) eq) (x : a) =
+ match wit with
+ | Refl -> if b then x else 0
+ | _ -> x
+;;
+[%%expect{|
+Line _, characters 29-30:
+ | Refl -> if b then x else 0
+ ^
+Error: This expression has type int but an expression was expected of type
+ a = int
+ This instance of int is ambiguous:
+ it would escape the scope of its equation
+|}]
+
+let ret_ei2 (type a) (b : bool) (wit : (a, int) eq) (x : a) =
+ match wit with
+ | Refl -> if b then x else 0
+ | _ -> x
+;;
+[%%expect{|
+Line _, characters 29-30:
+ | Refl -> if b then x else 0
+ ^
+Error: This expression has type int but an expression was expected of type
+ a = int
+ This instance of int is ambiguous:
+ it would escape the scope of its equation
+|}]
+
+
+let ret_f (type a b) (wit : (a, b) eq) (x : a) (y : b) =
+ match wit with
+ | Refl -> [x; y]
+ | _ -> [x]
+;;
+[%%expect{|
+Line _, characters 16-17:
+ | Refl -> [x; y]
+ ^
+Error: This expression has type b = a but an expression was expected of type
+ a
+ This instance of a is ambiguous:
+ it would escape the scope of its equation
+|}]
+
+let ret_g1 (type a b) (wit : (a, b) eq) (x : a) (y : b) =
+ match wit with
+ | Refl -> [x; y]
+ | _ -> [y]
+;;
+[%%expect{|
+Line _, characters 16-17:
+ | Refl -> [x; y]
+ ^
+Error: This expression has type b = a but an expression was expected of type
+ a
+ This instance of a is ambiguous:
+ it would escape the scope of its equation
+|}]
+
+(* First reported in MPR#7617: the typechecker arbitrarily picks a
+ representative for an ambivalent type escaping its scope.
+ The commit that was implemented poses problems of its own: we are now
+ unifying the type of the patterns in the environment of each pattern, instead
+ of the outter one. The code discussed in PR#7617 passes because each branch
+ contains the same equation, but consider the following cases: *)
+
+let f (type a b) (x : (a, b) eq) =
+ match x, [] with
+ | Refl, [(_ : a) | (_ : b)] -> []
+ | _, [(_ : a)] -> []
+;;
+[%%expect{|
+Line _, characters 4-29:
+ | Refl, [(_ : a) | (_ : b)] -> []
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This pattern matches values of type (a, b) eq * b list
+ but a pattern was expected which matches values of type 'a
+ This instance of b is ambiguous:
+ it would escape the scope of its equation
+|}]
+
+let g1 (type a b) (x : (a, b) eq) =
+ match x, [] with
+ | Refl, [(_ : a) | (_ : b)] -> []
+ | _, [(_ : b)] -> []
+;;
+[%%expect{|
+Line _, characters 4-29:
+ | Refl, [(_ : a) | (_ : b)] -> []
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This pattern matches values of type (a, b) eq * b list
+ but a pattern was expected which matches values of type 'a
+ This instance of b is ambiguous:
+ it would escape the scope of its equation
+|}]
+
+let g2 (type a b) (x : (a, b) eq) =
+ match x, [] with
+ | Refl, [(_ : b) | (_ : a)] -> []
+ | _, [(_ : a)] -> []
+;;
+[%%expect{|
+Line _, characters 4-29:
+ | Refl, [(_ : b) | (_ : a)] -> []
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This pattern matches values of type (a, b) eq * b list
+ but a pattern was expected which matches values of type 'a
+ This instance of b is ambiguous:
+ it would escape the scope of its equation
+|}]
+
+let h1 (type a b) (x : (a, b) eq) =
+ match x, [] with
+ | _, [(_ : a)] -> []
+ | Refl, [(_ : a) | (_ : b)] -> []
+;;
+[%%expect{|
+Line _, characters 4-29:
+ | Refl, [(_ : a) | (_ : b)] -> []
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This pattern matches values of type (a, b) eq * b list
+ but a pattern was expected which matches values of type 'a
+ This instance of b is ambiguous:
+ it would escape the scope of its equation
+|}]
+
+let h2 (type a b) (x : (a, b) eq) =
+ match x, [] with
+ | _, [(_ : b)] -> []
+ | Refl, [(_ : a) | (_ : b)] -> []
+;;
+[%%expect{|
+Line _, characters 4-29:
+ | Refl, [(_ : a) | (_ : b)] -> []
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This pattern matches values of type (a, b) eq * b list
+ but a pattern was expected which matches values of type 'a
+ This instance of b is ambiguous:
+ it would escape the scope of its equation
+|}]
+
+let h3 (type a b) (x : (a, b) eq) =
+ match x, [] with
+ | _, [(_ : a)] -> []
+ | Refl, [(_ : b) | (_ : a)] -> []
+;;
+[%%expect{|
+Line _, characters 4-29:
+ | Refl, [(_ : b) | (_ : a)] -> []
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This pattern matches values of type (a, b) eq * b list
+ but a pattern was expected which matches values of type 'a
+ This instance of b is ambiguous:
+ it would escape the scope of its equation
+|}]
+(* TEST
+ * expect
+*)
+
type 'a ty =
| Int : int ty
| Bool : bool ty
[%%expect{|
type 'a ty = Int : int ty | Bool : bool ty
Line _, characters 2-30:
+ ..match tag with
+ | Bool -> x
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
Int
;;
[%%expect{|
Line _, characters 2-33:
+ ..match tag with
+ | Int -> x > 0
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
Bool
val f : 'a -> 'a ty -> bool = <fun>
|}, Principal{|
Line _, characters 12-13:
+ | Bool -> x
+ ^
Error: This expression has type t but an expression was expected of type bool
|}];;
(* val f : 'a -> 'a ty -> bool = <fun> *)
;;
[%%expect{|
Line _, characters 11-16:
+ | Int -> x > 0
+ ^^^^^
Error: This expression has type bool but an expression was expected of type
t = int
|}, Principal{|
Line _, characters 11-16:
+ | Int -> x > 0
+ ^^^^^
Error: This expression has type bool but an expression was expected of type t
|}];;
(* Error: This expression has type bool but an expression was expected of type
+(* TEST
+ * expect
+*)
+
(* Encoding generics using GADTs *)
(* (c) Alain Frisch / Lexifi *)
(* cf. http://www.lexifi.com/blog/dynamic-types *)
;;
[%%expect{|
Line _, characters 41-58:
+ | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
+ ^^^^^^^^^^^^^^^^^
Error: This pattern matches values of type a * a vlist
but a pattern was expected which matches values of type
$Tdyn_'a = $0 * $1
+(* TEST
+ * expect
+*)
+
(* Tests for nested equations (bind abstract types from other modules) *)
type _ t = Int : int t;;
[%%expect{|
val w_bool : bool t = Int
Line _, characters 34-37:
+ let f_bool (x : bool) : int = let Int = w_bool in x;; (* fail *)
+ ^^^
Error: This pattern matches values of type int t
but a pattern was expected which matches values of type bool t
Type int is not compatible with type bool
[%%expect{|
val w_spec : Arg.spec t = Int
Line _, characters 38-41:
+ let f_spec (x : Arg.spec) : int = let Int = w_spec in x;; (* fail *)
+ ^^^
Error: This pattern matches values of type int t
but a pattern was expected which matches values of type Arg.spec t
Type int is not compatible with type Arg.spec
--- /dev/null
+ambiguity.ml
+didier.ml
+dynamic_frisch.ml
+nested_equations.ml
+omega07.ml
+pr5332.ml
+pr5689.ml
+pr5785.ml
+pr5848.ml
+pr5906.ml
+pr5948.ml
+pr5981.ml
+pr5985.ml
+pr5989.ml
+pr5997.ml
+pr6158.ml
+pr6163.ml
+pr6174.ml
+pr6241.ml
+pr6690.ml
+pr6817.ml
+pr6934.ml
+pr6980.ml
+pr6993_bad.ml
+pr7016.ml
+pr7160.ml
+pr7214.ml
+pr7222.ml
+pr7230.ml
+pr7234.ml
+pr7260.ml
+pr7269.ml
+pr7298.ml
+pr7374.ml
+pr7378.ml
+pr7381.ml
+pr7390.ml
+pr7391.ml
+pr7397.ml
+pr7421.ml
+pr7432.ml
+pr7618.ml
+pr7747.ml
+term-conv.ml
+test.ml
+unify_mb.ml
+variables_in_mcomp.ml
+yallop_bugs.ml
+(* TEST
+ * expect
+*)
+
(*
An attempt at encoding omega examples from the 2nd Central European
Functional Programming School:
+(* TEST
+ * expect
+*)
+
type ('env, 'a) var =
| Zero : ('a * 'env, 'a) var
| Succ : ('env, 'a) var -> ('b * 'env, 'a) var
| Tbool : ('env, bool) typ
| Tvar : ('env, 'a) var -> ('env, 'a) typ
Line _, characters 5-6:
+ | _ -> . (* error *)
+ ^
Error: This match case could not be refuted.
Here is an example of a value that would reach it: (Tint, Tvar Zero)
|}];;
+(* TEST
+ * expect
+*)
+
type inkind = [ `Link | `Nonlink ]
type _ inline_t =
[%%expect{|
type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
Line _, characters 35-43:
+ | (Kind _, Ast_Text txt) -> Text txt
+ ^^^^^^^^
Error: This expression has type ([< inkind > `Nonlink ] as 'a) inline_t
but an expression was expected of type a inline_t
Type 'a = [< `Link | `Nonlink > `Nonlink ] is not compatible with type
+(* TEST
+ * expect
+*)
+
module Add (T : sig type two end) =
struct
type _ t =
end;;
[%%expect{|
Line _, characters 43-100:
+ ...........................................function
+ | One, One -> "two"
+ | Two, Two -> "four"
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
(Two, One)
+(* TEST
+ * expect
+*)
+
module B : sig
type (_, _) t = Eq: ('a, 'a) t
val f: 'a -> 'b -> ('a, 'b) t
[%%expect{|
module B :
sig type (_, _) t = Eq : ('a, 'a) t val f : 'a -> 'b -> ('a, 'b) t end
-Line _, characters 4-6:
-Error: The GADT constructor Eq of type B.t must be qualified in this pattern.
+val of_type : 'a -> 'a = <fun>
|}];;
+(* TEST
+ * expect
+*)
+
type _ constant =
| Int: int -> int constant
| Bool: bool -> bool constant
| Leq : ('a, 'a, bool) binop
| Add : (int, int, int) binop
Line _, characters 2-195:
+ ..match bop, x, y with
+ | Eq, Bool x, Bool y -> Bool (if x then y else not y)
+ | Leq, Int x, Int y -> Bool (x <= y)
+ | Leq, Bool x, Bool y -> Bool (x <= y)
+ | Add, Int x, Int y -> Int (x + y)
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
(Eq, Int _, _)
+(* TEST
+ * expect
+*)
+
type tag = [`TagA | `TagB | `TagC];;
type 'a poly =
type _ wrapPoly =
WrapPoly : 'a poly -> ([< `TagA of int | `TagB ] as 'a) wrapPoly
Line _, characters 23-27:
+ | WrapPoly ATag -> intA
+ ^^^^
Error: This expression has type ([< `TagA of 'b ] as 'a) -> 'b
but an expression was expected of type a -> int
Type [< `TagA of 'b ] as 'a is not compatible with type
;;
[%%expect{|
Line _, characters 9-17:
+ let _ = example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *)
+ ^^^^^^^^
Error: Unbound value example6
|}];;
+(* TEST
+ * expect
+*)
+
module F(S : sig type 'a t end) = struct
type _ ab =
A : int S.t ab
end;;
[%%expect{|
Line _, characters 47-84:
+ ...............................................match l, r with
+ | A, B -> "f A B"
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
(A, A)
end;;
[%%expect{|
Line _, characters 15-52:
+ ...............match l, r with
+ | A, B -> "f A B"
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
(A, A)
+(* TEST
+ * expect
+*)
+
(* Report from Jeremy Yallop *)
module F (S : sig type 'a s end) = struct
include S
end;; (* fail *)
[%%expect{|
Line _, characters 2-29:
+ type _ t = T : 'a -> 'a s t
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, a type variable cannot be deduced
from the type parameters.
|}];;
end;; (* fail *)
[%%expect{|
Line _, characters 2-86:
+ ..class ['a] c x =
+ object constraint 'a = 'b T.t val x' : 'b = x method x = x' end
Error: In this definition, a type variable cannot be deduced
from the type parameters.
|}];;
x;; (* fail *)
[%%expect{|
Line _, characters 0-49:
+ type 'x t = A of 'a constraint 'x = [< `X of 'a ] ;; (* fail *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, a type variable cannot be deduced
from the type parameters.
|}];;
type 'a t = A : 'a -> [< `X of 'a ] t;; (* fail *)
[%%expect{|
Line _, characters 0-37:
+ type 'a t = A : 'a -> [< `X of 'a ] t;; (* fail *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, a type variable cannot be deduced
from the type parameters.
|}];;
val eq : 'a = <poly>
val eq : ('a Queue.t, 'b Queue.t) eq = Eq
Line _, characters 0-33:
+ type _ t = T : 'a -> 'a Queue.t t;; (* fail *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, a type variable cannot be deduced
from the type parameters.
|}];;
end;; (* fail *)
[%%expect{|
Line _, characters 2-29:
+ type _ t = T : 'a -> 'a s t
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, a type variable cannot be deduced
from the type parameters.
|}];;
module rec M : (S with type 'a s = unit) = M;;
[%%expect{|
Line _, characters 16-17:
+ module rec M : (S with type 'a s = unit) = M;;
+ ^
Error: Unbound module type S
|}];;
(* For the above reason, we cannot allow the abstract declaration
[%%expect{|
type 'a q = Q
Line _, characters 0-36:
+ type +'a t = 'b constraint 'a = 'b q;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, a type variable has a variance that
cannot be deduced from the type parameters.
It was expected to be unrestricted, but it is covariant.
type -'a s = 'b constraint 'a = 'b t;; (* fail *)
[%%expect{|
Line _, characters 0-36:
+ type -'a s = 'b constraint 'a = 'b t;; (* fail *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, a type variable has a variance that
is not reflected by its occurrence in type parameters.
It was expected to be contravariant, but it is covariant.
type +'a s = 'b constraint 'a = 'b t q;; (* fail *)
[%%expect{|
Line _, characters 0-38:
+ type +'a s = 'b constraint 'a = 'b t q;; (* fail *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, a type variable has a variance that
cannot be deduced from the type parameters.
It was expected to be unrestricted, but it is covariant.
[%%expect{|
type +'a t = unit constraint 'a = 'b list
Line _, characters 0-27:
+ type _ g = G : 'a -> 'a t g;; (* fail *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, a type variable cannot be deduced
from the type parameters.
|}];;
+(* TEST
+ * expect
+*)
+
type (_, _) t =
Any : ('a, 'b) t
| Eq : ('a, 'a) t
type (_, _) t = Any : ('a, 'b) t | Eq : ('a, 'a) t
module M : sig type s = private [> `A ] val eq : (s, [ `A | `B ]) t end
Line _, characters 39-64:
+ .......................................function
+ | Any -> "Any"
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
Eq
val eq : (s, < a : int; b : bool >) t
end
Line _, characters 49-74:
+ .................................................function
+ | Any -> "Any"
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
Eq
+(* TEST
+ * expect
+*)
+
type (_, _) comp =
| Eq : ('a, 'a) comp
| Diff : ('a, 'b) comp
module U : sig type t = T end
module M : sig type t = T val comp : (U.t, t) comp end
Line _, characters 0-33:
+ match M.comp with | Diff -> false;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
Eq
module U : sig type t = { x : int; } end
module M : sig type t = { x : int; } val comp : (U.t, t) comp end
Line _, characters 0-33:
+ match M.comp with | Diff -> false;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
Eq
+(* TEST
+ * expect
+*)
+
type 'a t = T of 'a
type 'a s = S of 'a
type 'a s = S of 'a
type (_, _) eq = Refl : ('a, 'a) eq
Line _, characters 45-49:
+ let f : (int s, int t) eq -> unit = function Refl -> ();;
+ ^^^^
Error: This pattern matches values of type (int s, int s) eq
but a pattern was expected which matches values of type
(int s, int t) eq
+(* TEST
+ * expect
+*)
+
type _ nat =
Zero : [`Zero] nat
| Succ : 'a nat -> [`Succ of 'a] nat;;
[ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat ->
aux
Line _, characters 4-5:
+ | _ -> . (* error *)
+ ^
Error: This match case could not be refuted.
Here is an example of a value that would reach it:
Succ (Succ (Succ (Succ (Succ Zero))))
+(* TEST
+ * expect
+*)
+
type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
let f : type a o. ((a -> o) -> o) t -> (a -> o) -> o =
fun C k -> k (fun x -> x);;
[%%expect{|
type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
Line _, characters 24-25:
+ fun C k -> k (fun x -> x);;
+ ^
Error: This expression has type $0 but an expression was expected of type
$1 = ($2 -> $1) -> $1
|}];;
+(* TEST
+ * expect
+*)
+
type (_, _) t =
A : ('a, 'a) t
| B : string -> ('a, 'b) t
[%%expect{|
type (_, _) t = A : ('a, 'a) t | B : string -> ('a, 'b) t
Line _, characters 52-74:
+ ....................................................function
+ | B s -> s
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
A
+(* TEST
+ * expect
+*)
+
type 'a visit_action
type insert
Local : ('a, 'a * insert, 'a local_visit_action) context
| Global : ('a, 'a, 'a visit_action) context
Line _, characters 4-9:
+ | Local -> fun _ -> raise Exit
+ ^^^^^
Error: This pattern matches values of type
($0, $0 * insert, $0 local_visit_action) context
but a pattern was expected which matches values of type
Local : ('a, 'a * insert, 'a local_visit_action) context
| Global : ('a, 'a, 'a visit_action) context
Line _, characters 4-10:
+ | Global -> fun _ -> raise Exit
+ ^^^^^^
Error: This pattern matches values of type ($1, $1, visit_action) context
but a pattern was expected which matches values of type
($0, $0 * insert, visit_action) context
;;
[%%expect{|
Line _, characters 4-9:
+ | Local -> fun _ -> raise Exit
+ ^^^^^
Error: This pattern matches values of type
($'a, $'a * insert, $'a local_visit_action) context
but a pattern was expected which matches values of type
The type constructor $'a would escape its scope
|}, Principal{|
Line _, characters 4-10:
+ | Global -> fun _ -> raise Exit
+ ^^^^^^
Error: This pattern matches values of type ($1, $1, visit_action) context
but a pattern was expected which matches values of type
($0, $0 * insert, visit_action) context
+(* TEST
+ * expect
+*)
+
module A = struct
type nil = Cstr
end
+(* TEST
+ * expect
+*)
+
type nonrec t = A : t;;
[%%expect{|
Line _, characters 16-21:
+ type nonrec t = A : t;;
+ ^^^^^
Error: GADT case syntax cannot be used in a 'nonrec' block.
|}]
+(* TEST
+ * expect
+*)
+
type 'a t = [< `Foo | `Bar] as 'a;;
type 'a s = [< `Foo | `Bar | `Baz > `Bar] as 'a;;
type aux = Aux : ([< `Bar | `Foo ] as 'a) t second * ('a -> int) -> aux
val it : [< `Bar | `Foo > `Bar ] = `Bar
Line _, characters 27-29:
+ let g (Aux(Second, f)) = f it;;
+ ^^
Error: This expression has type [< `Bar | `Foo > `Bar ]
but an expression was expected of type [< `Bar | `Foo ]
Types for tag `Bar are incompatible
+(* TEST
+ * expect
+*)
+
type (_, _) eqp = Y : ('a, 'a) eqp | N : string -> ('a, 'b) eqp
let f : ('a list, 'a) eqp -> unit = function N s -> print_string s;;
[%%expect{|
type (_, _) eqp = Y : ('a, 'a) eqp | N : string -> ('a, 'b) eqp
Line _, characters 36-66:
+ let f : ('a list, 'a) eqp -> unit = function N s -> print_string s;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
Y
+(* TEST
+ * expect
+*)
+
type (_, _) t =
| Nil : ('tl, 'tl) t
| Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t;;
Nil : ('tl, 'tl) t
| Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t
Line _, characters 9-43:
+ let get1 (Cons (x, _) : (_ * 'a, 'a) t) = x ;; (* warn, cf PR#6993 *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
Nil
val get1' : ('b * 'a as 'a, 'a) t -> 'b = <fun>
|}, Principal{|
Line _, characters 4-7:
+ | Nil -> assert false ;; (* ok *)
+ ^^^
Error: This pattern matches values of type ('b * 'a, 'b * 'a) t
but a pattern was expected which matches values of type
('b * 'a, 'a) t
+(* TEST
+ * expect
+*)
+
type _ t =
Int : int -> int t | String : string -> string t | Same : 'l t -> 'l t;;
let rec f = function Int x -> x | Same s -> f s;;
| Same : 'l t -> 'l t
val f : int t -> int = <fun>
Line _, characters 0-97:
+ type 'a tt = 'a t =
+ Int : int -> int tt | String : string -> string tt | Same : 'l1 t -> 'l2 tt..
Error: This variant or record definition does not match that of type 'a t
The types for field Same are not equal.
|}];;
+(* TEST
+ * expect
+*)
+
type _ t = I : int t;;
let f (type a) (x : a t) =
[%%expect{|
type _ t = I : int t
Line _, characters 9-10:
+ let (I : a t) = x (* fail because of toplevel let *)
+ ^
Error: This pattern matches values of type int t
but a pattern was expected which matches values of type a t
Type int is not compatible with type a
[%%expect{|
type (_, _) eq = Refl : ('a, 'a) eq
Line _, characters 10-14:
+ let (Refl : (int, a) eq) = M.e (* must fail for soundness *)
+ ^^^^
Error: This pattern matches values of type (int, int) eq
but a pattern was expected which matches values of type (int, a) eq
Type int is not compatible with type a
+(* TEST
+ * expect
+*)
+
type +'a n = private int
type nil = private Nil_type
type (_,_) elt =
| Elt : 'nat n -> ('l, 'nat -> 'l) elt
type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t
Line _, characters 11-18:
+ let Cons(Elt dim, _) = sh in ()
+ ^^^^^^^
Error: This pattern matches values of type ($Cons_'x, 'a -> $Cons_'x) elt
but a pattern was expected which matches values of type
($Cons_'x, 'a -> $'b -> nil) elt
| Elt : 'nat n -> ('l, 'nat -> 'l) elt
type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t
Line _, characters 6-22:
+ let Cons(Elt dim, _) = sh in ()
+ ^^^^^^^^^^^^^^^^
Error: This pattern matches values of type ('a -> $0 -> nil) t
but a pattern was expected which matches values of type
('a -> 'b -> nil) t
+(* TEST
+ * expect
+*)
+
type _ t = T : int t;;
(* Should raise Not_found *)
+(* TEST
+ * expect
+*)
+
type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq;;
type 'a t;;
let f (type a) (Neq n : (a, a t) eq) = n;; (* warn! *)
type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq
type 'a t
Line _, characters 15-40:
+ let f (type a) (Neq n : (a, a t) eq) = n;; (* warn! *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
Eq
end;;
[%%expect{|
Line _, characters 16-43:
+ let f (type a) (Neq n : (a, a T.t) eq) = n (* warn! *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
Eq
+(* TEST
+ * expect
+*)
+
type bar = < bar: unit >
type _ ty = Int : int ty
type _ ty = Int : int ty
type dyn = Dyn : 'a ty -> dyn
Line _, characters 0-108:
+ class foo =
+ object (this)
+ method foo (Dyn ty) =
+ match ty with
+ | Int -> (this :> bar)
+ end.................................
Error: This class should be virtual.
The following methods are undefined : bar
|}];;
+(* TEST
+ * expect
+*)
+
type s = [`A | `B] and sub = [`B];;
type +'a t = T : [< `Conj of 'a & sub | `Other of string] -> 'a t;; (* ok *)
and sub = [ `B ]
type +'a t = T : [< `Conj of 'a & sub | `Other of string ] -> 'a t
Line _, characters 6-47:
+ let f (T (`Other msg) : s t) = print_string msg;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
T (`Conj _)
val x : t
end
Line _, characters 12-59:
+ let () = M.(match x with T (`Other msg) -> print_string msg);; (* warn *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
T (`Conj _)
val e : elim -> unit
end
Line _, characters 21-57:
+ let () = M.(e { ex = fun (`Other msg) -> print_string msg });; (* warn *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
`Conj _
+(* TEST
+ * expect
+*)
+
type t = T : t;;
module M : sig
+(* TEST
+ * expect
+*)
+
type ('a, 'b) eq = Refl : ('a, 'a) eq
module type S = sig
end;; (* should fail *)
[%%expect{|
Line _, characters 16-20:
+ fun Refl -> Refl
+ ^^^^
Error: This expression has type (a, a) eq
but an expression was expected of type (a, t) eq
Type a is not compatible with type t = [ `Rec of 'a ] X.t as 'a
end;; (* should fail *)
[%%expect{|
Line _, characters 21-25:
+ fun Refl Refl -> Refl;;
+ ^^^^
Error: This expression has type (a, a) eq
but an expression was expected of type (a, a X.t X.t) eq
Type a = b X.t is not compatible with type a X.t X.t
+(* TEST
+ * expect
+*)
+
module X = struct
type t =
| A : 'a * 'b * ('a -> unit) -> t
end;; (* should fail *)
[%%expect{|
Line _, characters 2-54:
+ ..type t = X.t =
+ | A : 'a * 'b * ('b -> unit) -> t
Error: This variant or record definition does not match that of type X.t
The types for field A are not equal.
|}]
+(* TEST
+ * expect
+*)
+
type (_,_) eql = Refl : ('a, 'a) eql;;
[%%expect{|
type (_, _) eql = Refl : ('a, 'a) eql
+(* TEST
+ * expect
+*)
+
type empty = Empty and filled = Filled
type ('a,'fout,'fin) opt =
| N : ('a, 'f, 'f) opt
fun (Either (Y a, N)) -> a;;
[%%expect{|
Line _, characters 2-28:
+ fun (Either (Y a, N)) -> a;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
Either (N, Y _)
+(* TEST
+ * expect
+*)
+
class virtual child1 parent =
object
method private parent = parent
- : < child : unit -> child2; previous : child2 option > = <obj>
|}]
-(* Didn't work in 4.03 *)
+(* Didn't work in 4.03, but works in 4.07 *)
let _ =
object(self)
method previous = None
in o
end;;
[%%expect{|
-Line _, characters 16-22:
-Error: The method parent has type < child : 'a; previous : 'b option >
- but is expected to have type < previous : < .. > option; .. >
- Self type cannot escape its class
+- : < child : child2; previous : child2 option > = <obj>
+|}]
+
+(* Also didn't work in 4.03 *)
+
+type gadt = Not_really_though : gadt
+
+let _ =
+ object(self)
+ method previous = None
+ method child Not_really_though =
+ object
+ inherit child1 self
+ inherit child2
+ end
+ end;;
+[%%expect{|
+type gadt = Not_really_though : gadt
+- : < child : gadt -> child2; previous : child2 option > = <obj>
|}]
+(* TEST
+ * expect
+*)
+
type +'a t
class type a = object
+(* TEST
+ * expect
+*)
+
type (_, _) eq = Refl : ('a, 'a) eq;;
type empty = (int, unit) eq;;
[%%expect{|
| Error (lazy _) -> .;;
[%%expect{|
Line _, characters 4-18:
+ | Error (lazy _) -> .;;
+ ^^^^^^^^^^^^^^
Error: This match case could not be refuted.
Here is an example of a value that would reach it: Error lazy _
|}]
| Error (lazy Refl) -> .;;
[%%expect{|
Line _, characters 16-20:
+ | Error (lazy Refl) -> .;;
+ ^^^^
Error: This pattern matches values of type (int, int) eq
but a pattern was expected which matches values of type
empty = (int, unit) eq
+(* TEST
+ * expect
+*)
+
#labels false;;
type (_,_) eql = Refl : ('a, 'a) eql
type s = x:int -> y:float -> unit
;;
[%%expect{|
Line _, characters 2-30:
+ function `R {silly} -> silly
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
`L Refl
+++ /dev/null
-type _ t = I : int t;;
-let f (type a) (x : a t) (y : int) =
- match x, y with
- | I, (_:a) -> ()
-;;
-[%%expect{|
-type _ t = I : int t
-val f : 'a t -> int -> unit = <fun>
-|}]
-
-type ('a, 'b) eq = Refl : ('a, 'a) eq;;
-let ok (type a b) (x : (a, b) eq) =
- match x, [] with
- | Refl, [(_ : a) | (_ : b)] -> []
-;;
-[%%expect{|
-type ('a, 'b) eq = Refl : ('a, 'a) eq
-Line _, characters 2-54:
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-(Refl, _::_::_)
-Line _, characters 22-23:
-Warning 12: this sub-pattern is unused.
-val ok : ('a, 'b) eq -> 'c list = <fun>
-|}]
-let fails (type a b) (x : (a, b) eq) =
- match x, [] with
- | Refl, [(_ : a) | (_ : b)] -> []
- | Refl, [(_ : b) | (_ : a)] -> []
-;;
-[%%expect{|
-Line _, characters 2-90:
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-(Refl, _::_::_)
-Line _, characters 22-23:
-Warning 12: this sub-pattern is unused.
-Line _, characters 4-29:
-Warning 11: this match case is unused.
-val fails : ('a, 'b) eq -> 'c list = <fun>
-|}]
-
-(* branches must be unified! *)
-let x = match [] with ["1"] -> 1 | [1.0] -> 2 | [1] -> 3 | _ -> 4;;
-[%%expect{|
-Line _, characters 35-40:
-Error: This pattern matches values of type float list
- but a pattern was expected which matches values of type string list
- Type float is not compatible with type string
-|}]
--- /dev/null
+(* TEST
+ * expect
+*)
+
+type _ t = I : int t;;
+let f (type a) (x : a t) (y : int) =
+ match x, y with
+ | I, (_:a) -> ()
+;;
+[%%expect{|
+type _ t = I : int t
+val f : 'a t -> int -> unit = <fun>
+|}]
+
+type ('a, 'b) eq = Refl : ('a, 'a) eq;;
+let ok (type a b) (x : (a, b) eq) =
+ match x, [] with
+ | Refl, [(_ : a) | (_ : b)] -> []
+;;
+[%%expect{|
+type ('a, 'b) eq = Refl : ('a, 'a) eq
+Line _, characters 4-29:
+ | Refl, [(_ : a) | (_ : b)] -> []
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This pattern matches values of type (a, b) eq * b list
+ but a pattern was expected which matches values of type 'a
+ This instance of b is ambiguous:
+ it would escape the scope of its equation
+|}]
+let fails (type a b) (x : (a, b) eq) =
+ match x, [] with
+ | Refl, [(_ : a) | (_ : b)] -> []
+ | Refl, [(_ : b) | (_ : a)] -> []
+;;
+[%%expect{|
+Line _, characters 4-29:
+ | Refl, [(_ : a) | (_ : b)] -> []
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This pattern matches values of type (a, b) eq * b list
+ but a pattern was expected which matches values of type 'a
+ This instance of b is ambiguous:
+ it would escape the scope of its equation
+|}]
+
+(* branches must be unified! *)
+let x = match [] with ["1"] -> 1 | [1.0] -> 2 | [1] -> 3 | _ -> 4;;
+[%%expect{|
+Line _, characters 35-40:
+ let x = match [] with ["1"] -> 1 | [1.0] -> 2 | [1] -> 3 | _ -> 4;;
+ ^^^^^
+Error: This pattern matches values of type float list
+ but a pattern was expected which matches values of type string list
+ Type float is not compatible with type string
+|}]
--- /dev/null
+(* TEST
+ * expect
+*)
+
+type (_,_) eq = Refl : ('a,'a) eq
+
+module M = struct type t end
+module N : sig type t = private M.t val eq : (t, M.t) eq end =
+ struct type t = M.t let eq = Refl end;;
+
+(*
+ as long as we are casting between M.t and N.t
+ there is no problem, this will type check.
+*)
+
+let f x = match N.eq with Refl -> (x : N.t :> M.t);;
+[%%expect{|
+type (_, _) eq = Refl : ('a, 'a) eq
+module M : sig type t end
+module N : sig type t = private M.t val eq : (t, M.t) eq end
+val f : N.t -> M.t = <fun>
+|}]
+let f x = match N.eq with Refl -> (x : M.t :> N.t);;
+[%%expect{|
+Line _, characters 34-50:
+ let f x = match N.eq with Refl -> (x : M.t :> N.t);;
+ ^^^^^^^^^^^^^^^^
+Error: Type M.t is not a subtype of N.t
+|}]
+
+(*
+ but as soon we're trying to cast to another type,
+ the type checker will never return and memory
+ consumption will increase drastically.
+*)
+(* TEST
+ * expect
+*)
+
(* HOAS to de Bruijn, by chak *)
(* http://www.cse.unsw.edu.au/~chak/haskell/term-conv/ *)
+(* TEST
+ * expect
+*)
+
module Exp =
struct
;;
[%%expect{|
Line _, characters 6-34:
+ ......function
+ | C2 x -> x
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
C1 _
Line _, characters 6-77:
+ ......function
+ | Foo _ , Foo _ -> true
+ | Bar _, Bar _ -> true
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
(Bar _, Foo _)
end;;
[%%expect{|
Line _, characters 10-18:
+ class c (Some x) = object method x : int = x end
+ ^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
None
Line _, characters 10-18:
+ class d (Just x) = object method x : int = x end
+ ^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
Nothing
end;;
[%%expect{|
Line _, characters 43-44:
+ let g : int t -> int = function I -> 1 | _ -> 2 (* warn *)
+ ^
Warning 56: this match case is unreachable.
Consider replacing it with a refutation case '<pat> -> .'
module PR6220 :
end;;
[%%expect{|
Line _, characters 4-50:
+ ....match x with
+ | String s -> print_endline s.................
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
Any
;;
[%%expect{|
Line _, characters 21-22:
+ let eval (D x) = x
+ ^
Error: This expression has type $D_'a t
but an expression was expected of type 'a
The type constructor $D_'a would escape its scope
;;
[%%expect{|
Line _, characters 11-19:
+ | (IntLit _ | BoolLit _) -> ()
+ ^^^^^^^^
Error: This pattern matches values of type int t
but a pattern was expected which matches values of type s t
Type int is not compatible with type s
end
|}, Principal{|
Line _, characters 19-20:
+ | BoolLit b -> b
+ ^
Error: This expression has type bool but an expression was expected of type s
|}];;
end;;
[%%expect{|
Line _, characters 28-29:
+ let f = function A -> 1 | B -> 2
+ ^
Error: This variant pattern is expected to have type a
The constructor B does not belong to type a
|}, Principal{|
Line _, characters 28-29:
+ let f = function A -> 1 | B -> 2
+ ^
Error: This pattern matches values of type b
but a pattern was expected which matches values of type a
|}];;
end;;
[%%expect{|
Line _, characters 6-9:
+ Foo -> 5
+ ^^^
Error: This pattern matches values of type 'a t
but a pattern was expected which matches values of type int
|}];;
;;
[%%expect{|
Line _, characters 18-30:
+ function Int -> ky (1 : a) 1 (* fails *)
+ ^^^^^^^^^^^^
Error: This expression has type a = int
but an expression was expected of type 'a
This instance of int is ambiguous:
;;
[%%expect{|
Line _, characters 30-42:
+ let r = match x with Int -> ky (1 : a) 1 (* fails *)
+ ^^^^^^^^^^^^
Error: This expression has type a = int
but an expression was expected of type 'a
This instance of int is ambiguous:
;;
[%%expect{|
Line _, characters 30-42:
+ let r = match x with Int -> ky 1 (1 : a) (* fails *)
+ ^^^^^^^^^^^^
Error: This expression has type a = int
but an expression was expected of type 'a
This instance of int is ambiguous:
;; (* fails because u : (int | a) option ref *)
[%%expect{|
Line _, characters 46-48:
+ begin match x with Int -> u := Some 1; r := !u end;
+ ^^
Error: This expression has type int option
but an expression was expected of type a option
Type int is not compatible with type a = int
[%%expect{|
val either : 'a -> 'a -> 'a = <fun>
Line _, characters 44-45:
+ match v with Int -> let y = either 1 x in y
+ ^
Error: This expression has type a = int
but an expression was expected of type 'a
This instance of int is ambiguous:
;; (* fails because of aliasing... *)
[%%expect{|
Line _, characters 46-47:
+ let module M = struct type b = a let z = (y : b) end
+ ^
Error: This expression has type a = int
but an expression was expected of type b = int
This instance of int is ambiguous:
[%%expect{|
type (_, _) eq = Eq : ('a, 'a) eq
Line _, characters 4-90:
+ ....f : type a b. (a,b) eq -> (<m : a; ..> as 'c) -> (<m : b; ..> as 'c) =
+ fun Eq o -> o
Error: The universal type variable 'b cannot be generalized:
it is already bound to another variable.
|}];;
;; (* fail *)
[%%expect{|
Line _, characters 14-15:
+ fun Eq o -> o
+ ^
Error: This expression has type < m : a; .. >
but an expression was expected of type < m : b; .. >
Type a is not compatible with type b = a
match eq with Eq -> o ;; (* should fail *)
[%%expect{|
Line _, characters 22-23:
+ match eq with Eq -> o ;; (* should fail *)
+ ^
Error: This expression has type < m : a; .. >
but an expression was expected of type < m : b; .. >
Type a is not compatible with type b = a
val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = <fun>
|}, Principal{|
Line _, characters 44-45:
+ let r : < m : b > = match eq with Eq -> o in (* fail with principal *)
+ ^
Error: This expression has type < m : a >
but an expression was expected of type < m : b >
Type a is not compatible with type b = a
r;;
[%%expect{|
Line _, characters 44-45:
+ let r : < m : b > = match eq with Eq -> o in (* fail *)
+ ^
Error: This expression has type < m : a; .. >
but an expression was expected of type < m : b >
Type a is not compatible with type b = a
fun Eq o -> o ;; (* fail *)
[%%expect{|
Line _, characters 14-15:
+ fun Eq o -> o ;; (* fail *)
+ ^
Error: This expression has type [> `A of a ]
but an expression was expected of type [> `A of b ]
Type a is not compatible with type b = a
This instance of a is ambiguous:
it would escape the scope of its equation
+|}, Principal{|
+Line _, characters 9-15:
+ fun Eq o -> o ;; (* fail *)
+ ^^^^^^
+Error: This expression has type ([> `A of b ] as 'a) -> 'a
+ but an expression was expected of type [> `A of a ] -> [> `A of b ]
+ Types for tag `A are incompatible
|}];;
let f (type a b) (eq : (a,b) eq) (v : [> `A of a]) : [> `A of b] =
match eq with Eq -> v ;; (* should fail *)
[%%expect{|
Line _, characters 22-23:
+ match eq with Eq -> v ;; (* should fail *)
+ ^
Error: This expression has type [> `A of a ]
but an expression was expected of type [> `A of b ]
Type a is not compatible with type b = a
fun Eq o -> o ;; (* fail *)
[%%expect{|
Line _, characters 4-84:
+ ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
+ fun Eq o -> o..............
Error: This definition has type
('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c
which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c
val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = <fun>
|}, Principal{|
Line _, characters 49-50:
+ let r : [`A of b | `B] = match eq with Eq -> o in (* fail with principal *)
+ ^
Error: This expression has type [ `A of a | `B ]
but an expression was expected of type [ `A of b | `B ]
Type a is not compatible with type b = a
r;;
[%%expect{|
Line _, characters 49-50:
+ let r : [`A of b | `B] = match eq with Eq -> o in (* fail *)
+ ^
Error: This expression has type [> `A of a | `B ]
but an expression was expected of type [ `A of b | `B ]
Type a is not compatible with type b = a
;; (* warn *)
[%%expect{|
Line _, characters 2-153:
+ ..match x, y with
+ | _, A z -> z
+ | _, B z -> if z then 1 else 2
+ | _, C z -> truncate z
+ | TE TC, D [|1.0|] -> 14
+ | TA, D 0 -> -1
+ | TA, D z -> z
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
(TE TC, D [| 0. |])
;; (* fail *)
[%%expect{|
Line _, characters 6-13:
+ | D [|1.0|], TE TC -> 14
+ ^^^^^^^
Error: This pattern matches values of type 'a array
but a pattern was expected which matches values of type a
|}];;
[%%expect{|
type ('a, 'b) pair = { right : 'a; left : 'b; }
Line _, characters 25-32:
+ | {left=TE TC; right=D [|1.0|]} -> 14
+ ^^^^^^^
Error: This pattern matches values of type 'a array
but a pattern was expected which matches values of type a
|}];;
[%%expect{|
type ('a, 'b) pair = { left : 'a; right : 'b; }
Line _, characters 2-244:
+ ..match {left=x; right=y} with
+ | {left=_; right=A z} -> z
+ | {left=_; right=B z} -> if z then 1 else 2
+ | {left=_; right=C z} -> truncate z
+ | {left=TE TC; right=D [|1.0|]} -> 14
+ | {left=TA; right=D 0} -> -1
+ | {left=TA; right=D z} -> z
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
{left=TE TC; right=D [| 0. |]}
[%%expect{|
module M : sig type 'a t val eq : ('a t, 'b t) eq end
Line _, characters 17-19:
+ function Eq -> Eq (* fail *)
+ ^^
Error: This expression has type (a, a) eq
but an expression was expected of type (a, b) eq
Type a is not compatible with type b
type _ int_foo = IF_constr : < foo : int; .. > int_foo
type _ int_bar = IB_constr : < bar : int; .. > int_bar
Line _, characters 3-4:
+ (x:<foo:int>)
+ ^
Error: This expression has type t = < foo : int; .. >
but an expression was expected of type < foo : int >
Type $0 = < bar : int; .. > is not compatible with type < >
;;
[%%expect{|
Line _, characters 3-4:
+ (x:<foo:int;bar:int>)
+ ^
Error: This expression has type t = < foo : int; .. >
but an expression was expected of type < bar : int; foo : int >
Type $0 = < bar : int; .. > is not compatible with type < bar : int >
;;
[%%expect{|
Line _, characters 2-26:
+ (x:<foo:int;bar:int;..>)
+ ^^^^^^^^^^^^^^^^^^^^^^^^
Error: This expression has type < bar : int; foo : int; .. >
but an expression was expected of type 'a
The type constructor $1 would escape its scope
[%%expect{|
val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = <fun>
|}];;
+
+let f : type a b. (a,b) eq -> (a,int) eq -> a -> b -> _ = fun ab aint a b ->
+ let Eq = aint in
+ let x =
+ let Eq = ab in
+ if true then a else b
+ in ignore x
+;; (* ok *)
+[%%expect{|
+Line _, characters 24-25:
+ if true then a else b
+ ^
+Error: This expression has type b = int
+ but an expression was expected of type a = int
+ Type b = int is not compatible with type int
+ This instance of int is ambiguous:
+ it would escape the scope of its equation
+|}];;
+
+let f : type a b. (a,b) eq -> (b,int) eq -> a -> b -> _ = fun ab bint a b ->
+ let Eq = bint in
+ let x =
+ let Eq = ab in
+ if true then a else b
+ in ignore x
+;; (* ok *)
+[%%expect{|
+Line _, characters 24-25:
+ if true then a else b
+ ^
+Error: This expression has type b = int
+ but an expression was expected of type a = int
+ Type int is not compatible with type a = int
+ This instance of int is ambiguous:
+ it would escape the scope of its equation
+|}];;
+
+let f (type a b c) (b : bool) (w1 : (a,b) eq) (w2 : (a,int) eq) (x : a) (y : b) =
+ let Eq = w1 in
+ let Eq = w2 in
+ if b then x else y
+;;
+[%%expect{|
+Line _, characters 19-20:
+ if b then x else y
+ ^
+Error: This expression has type b = int
+ but an expression was expected of type a = int
+ Type a = int is not compatible with type a = int
+ This instance of int is ambiguous:
+ it would escape the scope of its equation
+|}];;
+
+let f (type a b c) (b : bool) (w1 : (a,b) eq) (w2 : (a,int) eq) (x : a) (y : b) =
+ let Eq = w1 in
+ let Eq = w2 in
+ if b then y else x
+[%%expect{|
+Line _, characters 19-20:
+ if b then y else x
+ ^
+Error: This expression has type a = int
+ but an expression was expected of type b = int
+ This instance of int is ambiguous:
+ it would escape the scope of its equation
+|}];;
+(* TEST
+ * expect
+*)
+
(* First-Order Unification by Structural Recursion *)
(* Conor McBride, JFP 13(6) *)
(* http://strictlypositive.org/publications.html *)
--- /dev/null
+(* TEST
+ * expect
+*)
+
+module M = struct
+ type 'a s = 'a
+ type t = T : 'a s -> t
+end
+
+module N = struct
+ type 'a s = 'a
+ type t = T : 'a s -> t
+end
+
+type (_, _) eq = Refl : ('a, 'a) eq
+
+let f (x : (M.t, N.t) eq)=
+ match x with
+ | Refl -> ()
+
+[%%expect{|
+module M : sig type 'a s = 'a type t = T : 'a s -> t end
+module N : sig type 'a s = 'a type t = T : 'a s -> t end
+type (_, _) eq = Refl : ('a, 'a) eq
+val f : (M.t, N.t) eq -> unit = <fun>
+|}]
+(* TEST
+ * expect
+*)
+
(* Injectivity *)
type (_, _) eq = Refl : ('a, 'a) eq
[%%expect{|
type (_, _) eq = Refl : ('a, 'a) eq
Line _, characters 44-52:
+ let f (Refl : (a T.t, b T.t) eq) = (x :> b)
+ ^^^^^^^^
Error: Type a is not a subtype of b
|}];;
;;
[%%expect{|
Line _, characters 0-36:
+ type (_, +_) eq = Refl : ('a, 'a) eq
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this GADT definition, the variance of some parameter
cannot be checked
|}];;
[%%expect{|
type _ t = IntLit : int t | BoolLit : bool t
Line _, characters 39-99:
+ .......................................function
+ | BoolLit, false -> false
+ | IntLit , 6 -> false
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
(IntLit, 0)
[%%expect{|
type ('a, 'b) pair = { fst : 'a; snd : 'b; }
Line _, characters 45-134:
+ .............................................function
+ | {fst = BoolLit; snd = false} -> false
+ | {fst = IntLit ; snd = 6} -> false
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
{fst=IntLit; snd=0}
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.expect
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * expect
+*)
+
module type S = sig type t [@@immediate] end;;
module F (M : S) : S = M;;
[%%expect{|
end;;
[%%expect{|
Line _, characters 2-31:
+ type t = string [@@immediate]
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Types marked with the immediate attribute must be
non-pointer types like int or bool
|}];;
end;;
[%%expect{|
Line _, characters 2-26:
+ type s = t [@@immediate]
+ ^^^^^^^^^^^^^^^^^^^^^^^^
Error: Types marked with the immediate attribute must be
non-pointer types like int or bool
|}];;
end;;
[%%expect{|
Line _, characters 42-70:
+ ..........................................struct
+ type t = string
+ end..
Error: Signature mismatch:
Modules do not match:
sig type t = string end
module FM_invalid = F (struct type t = string end);;
[%%expect{|
Line _, characters 23-49:
+ module M_invalid : S = struct type t = string end;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
Modules do not match: sig type t = string end is not included in S
Type declarations do not match:
end;;
[%%expect{|
Line _, characters 2-26:
+ type t = s [@@immediate]
+ ^^^^^^^^^^^^^^^^^^^^^^^^
Error: Types marked with the immediate attribute must be
non-pointer types like int or bool
|}];;
--- /dev/null
+immediate.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * toplevel
+*)
+
(*
Implicit unpack allows to omit the signature in (val ...) expressions.
+++ /dev/null
-
-# * * * * * * * * * val sort : (module Set.S with type elt = 'a) -> 'a list -> 'a list = <fun>
-val make_set : ('a -> 'a -> int) -> (module Set.S with type elt = 'a) = <fun>
-val sort_cmp : ('a -> 'a -> int) -> 'a list -> 'a list = <fun>
-module type S = sig type t val x : t end
-# val f : (module S with type t = int) -> int = <fun>
-# Characters 6-37:
- let f (module M : S with type t = 'a) = M.x;; (* Error *)
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The type of this packed module contains variables:
-(module S with type t = 'a)
-# val f : (module S with type t = 'a) -> 'a = <fun>
-# - : int = 1
-# type 'a s = { s : (module S with type t = 'a); }
-# - : int s = {s = <module>}
-# Characters 9-19:
- let f {s=(module M)} = M.x;; (* Error *)
- ^^^^^^^^^^
-Error: The type of this packed module contains variables:
-(module S with type t = 'a)
-# val f : 'a s -> 'a = <fun>
-# type s = { s : (module S with type t = int); }
-# val f : s -> int = <fun>
-# val f : s -> s -> int = <fun>
-# module type S = sig val x : int end
-# val f : (module S) -> int -> (module S) -> int = <fun>
-# Characters 8-37:
- let m = (module struct let x = 3 end);; (* Error *)
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The signature for this packaged module couldn't be inferred.
-# val m : (module S) = <module>
-# - : int = 7
-# - : int = 6
-# - : int = 3
-# Characters 4-14:
- let (module M) = m;; (* Error: only allowed in [let .. in] *)
- ^^^^^^^^^^
-Error: Modules are not allowed in this pattern.
-# Characters 14-24:
- class c = let (module M) = m in object end;; (* Error again *)
- ^^^^^^^^^^
-Error: Modules are not allowed in this pattern.
-# module M : S
-# module type S' = sig val f : int -> int end
-# - : int = 6
-# module type S = sig type t type u val x : t * u end
-val f :
- (module S with type t = int and type u = bool) list ->
- (module S with type u = bool) list = <fun>
-module TypEq :
- sig
- type ('a, 'b) t
- val apply : ('a, 'b) t -> 'a -> 'b
- val refl : ('a, 'a) t
- val sym : ('a, 'b) t -> ('b, 'a) t
- end
-module rec Typ :
- sig
- module type PAIR =
- sig
- type t
- and t1
- and t2
- val eq : (t, t1 * t2) TypEq.t
- val t1 : t1 Typ.typ
- val t2 : t2 Typ.typ
- end
- type 'a typ =
- Int of ('a, int) TypEq.t
- | String of ('a, string) TypEq.t
- | Pair of (module PAIR with type t = 'a)
- end
-val int : int Typ.typ = Int <abstr>
-val str : string Typ.typ = String <abstr>
-val pair : 'a Typ.typ -> 'b Typ.typ -> ('a * 'b) Typ.typ = <fun>
-val to_string : 'a Typ.typ -> 'a -> string = <fun>
-module type MapT =
- sig
- type key
- type +'a t
- val empty : 'a t
- val is_empty : 'a t -> bool
- val mem : key -> 'a t -> bool
- val add : key -> 'a -> 'a t -> 'a t
- val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
- val singleton : key -> 'a -> 'a t
- val remove : key -> 'a t -> 'a t
- val merge :
- (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
- val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
- val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
- val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
- val iter : (key -> 'a -> unit) -> 'a t -> unit
- val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
- val for_all : (key -> 'a -> bool) -> 'a t -> bool
- val exists : (key -> 'a -> bool) -> 'a t -> bool
- val filter : (key -> 'a -> bool) -> 'a t -> 'a t
- val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
- val cardinal : 'a t -> int
- val bindings : 'a t -> (key * 'a) list
- val min_binding : 'a t -> key * 'a
- val min_binding_opt : 'a t -> (key * 'a) option
- val max_binding : 'a t -> key * 'a
- val max_binding_opt : 'a t -> (key * 'a) option
- val choose : 'a t -> key * 'a
- val choose_opt : 'a t -> (key * 'a) option
- val split : key -> 'a t -> 'a t * 'a option * 'a t
- val find : key -> 'a t -> 'a
- val find_opt : key -> 'a t -> 'a option
- val find_first : (key -> bool) -> 'a t -> key * 'a
- val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
- val find_last : (key -> bool) -> 'a t -> key * 'a
- val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
- val map : ('a -> 'b) -> 'a t -> 'b t
- val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
- type data
- type map
- val of_t : data t -> map
- val to_t : map -> data t
- end
-type ('k, 'd, 'm) map =
- (module MapT with type data = 'd and type key = 'k and type map = 'm)
-val add : ('a, 'b, 'c) map -> 'a -> 'b -> 'c -> 'c = <fun>
-module SSMap :
- sig
- type key = String.t
- type 'a t = 'a Map.Make(String).t
- val empty : 'a t
- val is_empty : 'a t -> bool
- val mem : key -> 'a t -> bool
- val add : key -> 'a -> 'a t -> 'a t
- val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
- val singleton : key -> 'a -> 'a t
- val remove : key -> 'a t -> 'a t
- val merge :
- (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
- val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
- val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
- val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
- val iter : (key -> 'a -> unit) -> 'a t -> unit
- val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
- val for_all : (key -> 'a -> bool) -> 'a t -> bool
- val exists : (key -> 'a -> bool) -> 'a t -> bool
- val filter : (key -> 'a -> bool) -> 'a t -> 'a t
- val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
- val cardinal : 'a t -> int
- val bindings : 'a t -> (key * 'a) list
- val min_binding : 'a t -> key * 'a
- val min_binding_opt : 'a t -> (key * 'a) option
- val max_binding : 'a t -> key * 'a
- val max_binding_opt : 'a t -> (key * 'a) option
- val choose : 'a t -> key * 'a
- val choose_opt : 'a t -> (key * 'a) option
- val split : key -> 'a t -> 'a t * 'a option * 'a t
- val find : key -> 'a t -> 'a
- val find_opt : key -> 'a t -> 'a option
- val find_first : (key -> bool) -> 'a t -> key * 'a
- val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
- val find_last : (key -> bool) -> 'a t -> key * 'a
- val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
- val map : ('a -> 'b) -> 'a t -> 'b t
- val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
- type data = string
- type map = data t
- val of_t : 'a -> 'a
- val to_t : 'a -> 'a
- end
-val ssmap :
- (module MapT with type data = string and type key = string and type map =
- SSMap.map) =
- <module>
-# val ssmap :
- (module MapT with type data = string and type key = string and type map =
- SSMap.map) =
- <module>
-# val ssmap :
- (module MapT with type data = string and type key = string and type map =
- SSMap.map) =
- <module>
-# val ssmap :
- (module MapT with type data = SSMap.data and type key = SSMap.key and type map =
- SSMap.map) =
- <module>
-# val ssmap : (SSMap.key, SSMap.data, SSMap.map) map = <module>
-# - : SSMap.key -> SSMap.data -> SSMap.map -> SSMap.map = <fun>
-#
--- /dev/null
+val sort : (module Stdlib.Set.S with type elt = 'a) -> 'a list -> 'a list =
+ <fun>
+val make_set : ('a -> 'a -> int) -> (module Stdlib.Set.S with type elt = 'a) =
+ <fun>
+val sort_cmp : ('a -> 'a -> int) -> 'a list -> 'a list = <fun>
+module type S = sig type t val x : t end
+val f : (module S with type t = int) -> int = <fun>
+Characters 6-37:
+ let f (module M : S with type t = 'a) = M.x;; (* Error *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The type of this packed module contains variables:
+(module S with type t = 'a)
+val f : (module S with type t = 'a) -> 'a = <fun>
+- : int = 1
+type 'a s = { s : (module S with type t = 'a); }
+- : int s = {s = <module>}
+Characters 9-19:
+ let f {s=(module M)} = M.x;; (* Error *)
+ ^^^^^^^^^^
+Error: The type of this packed module contains variables:
+(module S with type t = 'a)
+val f : 'a s -> 'a = <fun>
+type s = { s : (module S with type t = int); }
+val f : s -> int = <fun>
+val f : s -> s -> int = <fun>
+module type S = sig val x : int end
+val f : (module S) -> int -> (module S) -> int = <fun>
+Characters 8-37:
+ let m = (module struct let x = 3 end);; (* Error *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The signature for this packaged module couldn't be inferred.
+val m : (module S) = <module>
+- : int = 7
+- : int = 6
+- : int = 3
+Characters 4-14:
+ let (module M) = m;; (* Error: only allowed in [let .. in] *)
+ ^^^^^^^^^^
+Error: Modules are not allowed in this pattern.
+Characters 14-24:
+ class c = let (module M) = m in object end;; (* Error again *)
+ ^^^^^^^^^^
+Error: Modules are not allowed in this pattern.
+module M : S
+module type S' = sig val f : int -> int end
+- : int = 6
+module type S = sig type t type u val x : t * u end
+val f :
+ (module S with type t = int and type u = bool) list ->
+ (module S with type u = bool) list = <fun>
+module TypEq :
+ sig
+ type ('a, 'b) t
+ val apply : ('a, 'b) t -> 'a -> 'b
+ val refl : ('a, 'a) t
+ val sym : ('a, 'b) t -> ('b, 'a) t
+ end
+module rec Typ :
+ sig
+ module type PAIR =
+ sig
+ type t
+ and t1
+ and t2
+ val eq : (t, t1 * t2) TypEq.t
+ val t1 : t1 Typ.typ
+ val t2 : t2 Typ.typ
+ end
+ type 'a typ =
+ Int of ('a, int) TypEq.t
+ | String of ('a, string) TypEq.t
+ | Pair of (module PAIR with type t = 'a)
+ end
+val int : int Typ.typ = Int <abstr>
+val str : string Typ.typ = String <abstr>
+val pair : 'a Typ.typ -> 'b Typ.typ -> ('a * 'b) Typ.typ = <fun>
+val to_string : 'a Typ.typ -> 'a -> string = <fun>
+module type MapT =
+ sig
+ type key
+ type +'a t
+ val empty : 'a t
+ val is_empty : 'a t -> bool
+ val mem : key -> 'a t -> bool
+ val add : key -> 'a -> 'a t -> 'a t
+ val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
+ val singleton : key -> 'a -> 'a t
+ val remove : key -> 'a t -> 'a t
+ val merge :
+ (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+ val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
+ val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+ val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+ val iter : (key -> 'a -> unit) -> 'a t -> unit
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val for_all : (key -> 'a -> bool) -> 'a t -> bool
+ val exists : (key -> 'a -> bool) -> 'a t -> bool
+ val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+ val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+ val cardinal : 'a t -> int
+ val bindings : 'a t -> (key * 'a) list
+ val min_binding : 'a t -> key * 'a
+ val min_binding_opt : 'a t -> (key * 'a) option
+ val max_binding : 'a t -> key * 'a
+ val max_binding_opt : 'a t -> (key * 'a) option
+ val choose : 'a t -> key * 'a
+ val choose_opt : 'a t -> (key * 'a) option
+ val split : key -> 'a t -> 'a t * 'a option * 'a t
+ val find : key -> 'a t -> 'a
+ val find_opt : key -> 'a t -> 'a option
+ val find_first : (key -> bool) -> 'a t -> key * 'a
+ val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
+ val find_last : (key -> bool) -> 'a t -> key * 'a
+ val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
+ val map : ('a -> 'b) -> 'a t -> 'b t
+ val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+ val to_seq : 'a t -> (key * 'a) Seq.t
+ val to_seq_from : key -> 'a t -> (key * 'a) Seq.t
+ val add_seq : (key * 'a) Seq.t -> 'a t -> 'a t
+ val of_seq : (key * 'a) Seq.t -> 'a t
+ type data
+ type map
+ val of_t : data t -> map
+ val to_t : map -> data t
+ end
+type ('k, 'd, 'm) map =
+ (module MapT with type data = 'd and type key = 'k and type map = 'm)
+val add : ('a, 'b, 'c) map -> 'a -> 'b -> 'c -> 'c = <fun>
+module SSMap :
+ sig
+ type key = String.t
+ type 'a t = 'a Map.Make(String).t
+ val empty : 'a t
+ val is_empty : 'a t -> bool
+ val mem : key -> 'a t -> bool
+ val add : key -> 'a -> 'a t -> 'a t
+ val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
+ val singleton : key -> 'a -> 'a t
+ val remove : key -> 'a t -> 'a t
+ val merge :
+ (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+ val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
+ val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+ val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+ val iter : (key -> 'a -> unit) -> 'a t -> unit
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val for_all : (key -> 'a -> bool) -> 'a t -> bool
+ val exists : (key -> 'a -> bool) -> 'a t -> bool
+ val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+ val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+ val cardinal : 'a t -> int
+ val bindings : 'a t -> (key * 'a) list
+ val min_binding : 'a t -> key * 'a
+ val min_binding_opt : 'a t -> (key * 'a) option
+ val max_binding : 'a t -> key * 'a
+ val max_binding_opt : 'a t -> (key * 'a) option
+ val choose : 'a t -> key * 'a
+ val choose_opt : 'a t -> (key * 'a) option
+ val split : key -> 'a t -> 'a t * 'a option * 'a t
+ val find : key -> 'a t -> 'a
+ val find_opt : key -> 'a t -> 'a option
+ val find_first : (key -> bool) -> 'a t -> key * 'a
+ val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
+ val find_last : (key -> bool) -> 'a t -> key * 'a
+ val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
+ val map : ('a -> 'b) -> 'a t -> 'b t
+ val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+ val to_seq : 'a t -> (key * 'a) Seq.t
+ val to_seq_from : key -> 'a t -> (key * 'a) Seq.t
+ val add_seq : (key * 'a) Seq.t -> 'a t -> 'a t
+ val of_seq : (key * 'a) Seq.t -> 'a t
+ type data = string
+ type map = data t
+ val of_t : 'a -> 'a
+ val to_t : 'a -> 'a
+ end
+val ssmap :
+ (module MapT with type data = string and type key = string and type map =
+ SSMap.map) =
+ <module>
+val ssmap :
+ (module MapT with type data = string and type key = string and type map =
+ SSMap.map) =
+ <module>
+val ssmap :
+ (module MapT with type data = string and type key = string and type map =
+ SSMap.map) =
+ <module>
+val ssmap :
+ (module MapT with type data = SSMap.data and type key = SSMap.key and type map =
+ SSMap.map) =
+ <module>
+val ssmap : (SSMap.key, SSMap.data, SSMap.map) map = <module>
+- : SSMap.key -> SSMap.data -> SSMap.map -> SSMap.map = <fun>
+
--- /dev/null
+implicit_unpack.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST *)
+
open StdLabels
open MoreLabels
+(* TEST *)
+
(* Full fledge version, using objects to structure code *)
open StdLabels
+(* TEST *)
+
(* Full fledge version, using objects to structure code *)
open StdLabels
--- /dev/null
+mixin2.ml
+mixin3.ml
+mixin.ml
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
type sexp = A of string | L of sexp list
type 'a t = 'a array
let _ = fun (_ : 'a t) -> ()
--- /dev/null
+core_array_reduced_ok.ml
+pr6303_bad.ml
+pr6946_bad.ml
--- /dev/null
+File "pr6303_bad.ml", line 11, characters 22-23:
+Error: This expression has type int foo
+ but an expression was expected of type string foo
+ Type int is not compatible with type string
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
type 'a foo = {x: 'a; y: int}
let r = {{x = 0; y = 0} with x = 0}
let r' : string foo = r
--- /dev/null
+File "pr6946_bad.ml", line 10, characters 8-11:
+Error: This expression has type int
+ This is not a function; it cannot be applied.
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
external foo : int = "%ignore";;
let _ = foo ();;
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-all: pr6939.ml
- $(MAKE) default
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.expect
-include $(BASEDIR)/makefiles/Makefile.common
-
-GENERATED_SOURCES = pr6939.ml *.flat-float
-
-ifeq "$(FLAT_FLOAT_ARRAY)" "true"
-suffix = -flat
-else
-suffix = -noflat
-endif
-
-pr6939.ml: pr6939.ml$(suffix) $(FLAT_FLOAT_ARRAY).flat-float
- cp $< $@
-
-%.flat-float:
- @rm -f $(GENERATED_SOURCES)
- @touch $@
+(* TEST
+ * expect
+*)
+
type 'a t = [`A of 'a t t] as 'a;; (* fails *)
[%%expect{|
Line _, characters 0-32:
+ type 'a t = [`A of 'a t t] as 'a;; (* fails *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The definition of t contains a cycle:
'a t t as 'a
|}, Principal{|
Line _, characters 0-32:
+ type 'a t = [`A of 'a t t] as 'a;; (* fails *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The definition of t contains a cycle:
[ `A of 'a t t ] as 'a
|}];;
type 'a t = [`A of 'a t t];; (* fails *)
[%%expect{|
Line _, characters 0-26:
+ type 'a t = [`A of 'a t t];; (* fails *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In the definition of t, type 'a t t should be 'a t
|}];;
type 'a t = [`A of 'a t t] constraint 'a = 'a t;; (* fails since 4.04 *)
[%%expect{|
Line _, characters 0-47:
+ type 'a t = [`A of 'a t t] constraint 'a = 'a t;; (* fails since 4.04 *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The type abbreviation t is cyclic
|}];;
type 'a t = [`A of 'a t] constraint 'a = 'a t;; (* fails since 4.04 *)
[%%expect{|
Line _, characters 0-45:
+ type 'a t = [`A of 'a t] constraint 'a = 'a t;; (* fails since 4.04 *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The type abbreviation t is cyclic
|}];;
type 'a t = [`A of 'a] as 'a;;
type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *)
[%%expect{|
Line _, characters 0-41:
+ type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The definition of v contains a cycle:
t
|}];;
;; (* fails *)
[%%expect{|
Line _, characters 2-44:
+ and 'o abs constraint 'o = 'o is_an_object
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The definition of abs contains a cycle:
'a is_an_object as 'a
|}];;
val y : (< > is_an_object, < > is_an_object) abs
end
Line _, characters 8-17:
+ let _ = PR6505a.y#bang;; (* fails *)
+ ^^^^^^^^^
Error: This expression has type
(< > PR6505a.is_an_object, < > PR6505a.is_an_object) PR6505a.abs
It has no method bang
val y : (< >, < >) abs
end
Line _, characters 8-17:
+ let _ = PR6505a.y#bang;; (* fails *)
+ ^^^^^^^^^
Error: This expression has type (< >, < >) PR6505a.abs
It has no method bang
|}]
val x : (([> `Foo of int ] as 'a) is_an_object, 'a is_an_object) abs
end
Line _, characters 23-57:
+ let () = print_endline (match PR6505b.x with `Bar s -> s);; (* fails *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
`Foo _
--- /dev/null
+(* TEST
+ * expect
+*)
+
+(*** Record ***)
+
+(* Expressions *)
+
+module M = struct
+ type r = { lbl : int }
+end
+;;
+[%%expect{|
+module M : sig type r = { lbl : int; } end
+|}]
+
+let before_a : M.r =
+ { lbl = 3 }
+;;
+[%%expect{|
+val before_a : M.r = {M.lbl = 3}
+|}]
+
+let a =
+ let x = ({ M.lbl = 3 } : M.r) in
+ x.lbl
+;;
+[%%expect{|
+val a : int = 3
+|}]
+
+let after_a =
+ let x = ({ M.lbl = 3 } : M.r) in
+ { x with lbl = 4 }
+;;
+[%%expect{|
+Line _, characters 2-20:
+ { x with lbl = 4 }
+ ^^^^^^^^^^^^^^^^^^
+Warning 23: all the fields are explicitly listed in this record:
+the 'with' clause is useless.
+val after_a : M.r = {M.lbl = 4}
+|}]
+
+let b =
+ let x = ({ contents = { M.lbl = 3 } } : M.r ref) in
+ x := { lbl = 4 }
+;;
+[%%expect{|
+val b : unit = ()
+|}, Principal{|
+Line _, characters 7-18:
+ x := { lbl = 4 }
+ ^^^^^^^^^^^
+Warning 18: this type-based record disambiguation is not principal.
+val b : unit = ()
+|}]
+
+let c =
+ let x = ({ contents = { M.lbl = 3 } } : M.r ref) in
+ !x.lbl
+;;
+[%%expect{|
+val c : int = 3
+|}]
+
+let d =
+ let x = ({ contents = { M.lbl = 3 } } : M.r ref) in
+ x.contents <- { lbl = 4 }
+;;
+[%%expect{|
+val d : unit = ()
+|}]
+
+let e =
+ let x = ({ contents = { M.lbl = 3 } } : M.r ref) in
+ { x with contents = { lbl = 4 } }
+;;
+[%%expect{|
+Line _, characters 24-27:
+ { x with contents = { lbl = 4 } }
+ ^^^
+Error: Unbound record field lbl
+|}]
+
+let f =
+ let x = ({ contents = { M.lbl = 3 } } : M.r ref) in
+ x.contents.lbl
+;;
+[%%expect{|
+val f : int = 3
+|}]
+
+(* Patterns *)
+
+let g (x : M.r) =
+ match x with
+ | { lbl = _ } -> ()
+;;
+[%%expect{|
+val g : M.r -> unit = <fun>
+|}]
+
+let h x =
+ match x with
+ | (_ : M.r) -> ()
+ | { lbl = _ } -> ()
+;;
+[%%expect{|
+Line _, characters 4-15:
+ | { lbl = _ } -> ()
+ ^^^^^^^^^^^
+Warning 11: this match case is unused.
+val h : M.r -> unit = <fun>
+|}, Principal{|
+Line _, characters 6-9:
+ | { lbl = _ } -> ()
+ ^^^
+Error: Unbound record field lbl
+|}]
+
+let i x =
+ match x with
+ | { lbl = _ } -> ()
+ | (_ : M.r) -> ()
+;;
+[%%expect{|
+Line _, characters 6-9:
+ | { lbl = _ } -> ()
+ ^^^
+Error: Unbound record field lbl
+|}]
+
+let j x =
+ match x with
+ | (_ : M.r)
+ | { lbl = _ } -> ()
+;;
+[%%expect{|
+Line _, characters 4-15:
+ | { lbl = _ } -> ()
+ ^^^^^^^^^^^
+Warning 12: this sub-pattern is unused.
+val j : M.r -> unit = <fun>
+|}]
+
+let k x =
+ match x with
+ | { lbl = _ }
+ | (_ : M.r) -> ()
+;;
+[%%expect{|
+Line _, characters 6-9:
+ | { lbl = _ }
+ ^^^
+Error: Unbound record field lbl
+|}]
+
+let l (x : M.r ref) =
+ match x with
+ | { contents = { lbl = _ } } -> ()
+;;
+[%%expect{|
+val l : M.r ref -> unit = <fun>
+|}]
+
+let m x =
+ match x with
+ | { contents = { lbl = _ } } -> ()
+;;
+[%%expect{|
+Line _, characters 19-22:
+ | { contents = { lbl = _ } } -> ()
+ ^^^
+Error: Unbound record field lbl
+|}]
+
+let n x =
+ match x with
+ | (_ : M.r ref) -> ()
+ | { contents = { lbl = _ } } -> ()
+;;
+[%%expect{|
+Line _, characters 4-30:
+ | { contents = { lbl = _ } } -> ()
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 11: this match case is unused.
+val n : M.r ref -> unit = <fun>
+|}, Principal{|
+Line _, characters 19-22:
+ | { contents = { lbl = _ } } -> ()
+ ^^^
+Error: Unbound record field lbl
+|}]
+
+let o x =
+ match x with
+ | { contents = { lbl = _ } } -> ()
+ | (_ : M.r ref) -> ()
+;;
+[%%expect{|
+Line _, characters 19-22:
+ | { contents = { lbl = _ } } -> ()
+ ^^^
+Error: Unbound record field lbl
+|}]
+
+let p x =
+ match x with
+ | (_ : M.r ref)
+ | { contents = { lbl = _ } } -> ()
+;;
+[%%expect{|
+Line _, characters 4-30:
+ | { contents = { lbl = _ } } -> ()
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 12: this sub-pattern is unused.
+val p : M.r ref -> unit = <fun>
+|}]
+
+let q x =
+ match x with
+ | { contents = { lbl = _ } }
+ | (_ : M.r ref) -> ()
+;;
+[%%expect{|
+Line _, characters 19-22:
+ | { contents = { lbl = _ } }
+ ^^^
+Error: Unbound record field lbl
+|}]
+
+let r arg =
+ match arg with
+ | (x : M.r ref) ->
+ !x.lbl
+;;
+[%%expect{|
+val r : M.r ref -> int = <fun>
+|}]
+
+let s arg =
+ match arg with
+ | (x : M.r ref) ->
+ x := { lbl = 4 }
+;;
+[%%expect{|
+val s : M.r ref -> unit = <fun>
+|}, Principal{|
+Line _, characters 9-20:
+ x := { lbl = 4 }
+ ^^^^^^^^^^^
+Warning 18: this type-based record disambiguation is not principal.
+val s : M.r ref -> unit = <fun>
+|}]
+
+let t = function
+ | ({ contents = { M.lbl = _ } } : M.r ref) as x ->
+ x := { lbl = 4 }
+;;
+[%%expect{|
+val t : M.r ref -> unit = <fun>
+|}, Principal{|
+Line _, characters 9-20:
+ x := { lbl = 4 }
+ ^^^^^^^^^^^
+Warning 18: this type-based record disambiguation is not principal.
+val t : M.r ref -> unit = <fun>
+|}]
+
+let u = function
+ | ({ contents = { M.lbl = _ } } : M.r ref) as x ->
+ !x.lbl
+;;
+[%%expect{|
+val u : M.r ref -> int = <fun>
+|}, Principal{|
+Line _, characters 7-10:
+ !x.lbl
+ ^^^
+Warning 18: this type-based field disambiguation is not principal.
+val u : M.r ref -> int = <fun>
+|}]
--- /dev/null
+(* TEST
+ * expect
+*)
+
+(* empty variant *)
+type t = |;;
+[%%expect{|
+type t = |
+|}];;
+
+let f (x:t) = match x with _ -> .
+[%%expect{|
+val f : t -> 'a = <fun>
+|}];;
+
+type m = A of t | B of int * t | C of {g:t}
+[%%expect{|
+type m = A of t | B of int * t | C of { g : t; }
+|}]
+
+let g (x:m) =
+ match x with
+ | A _ | B _ | C _ -> .
+[%%expect{|
+val g : m -> 'a = <fun>
+|}]
+
+let f : t option -> int = function None -> 3
+[%%expect{|
+val f : t option -> int = <fun>
+|}]
--- /dev/null
+(* TEST
+ * expect
+*)
+
+module rec A : sig
+ type t = int * string
+end = struct
+ type t = A | B
+
+ let f (x : t) =
+ match x with
+ | A -> ()
+ | B -> ()
+end;;
+[%%expect{|
+Line _, characters 6-97:
+ ......struct
+ type t = A | B
+
+ let f (x : t) =
+ match x with
+ | A -> ()
+ | B -> ()
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig type t = A.t = A | B val f : t -> unit end
+ is not included in
+ sig type t = int * string end
+ Type declarations do not match:
+ type t = A.t = A | B
+ is not included in
+ type t = int * string
+|}]
+
+module rec B : sig
+ type 'a t = 'a
+end = struct
+ type 'a t = A of 'a | B
+
+ let f (x : _ t) =
+ match x with
+ | A _ -> ()
+ | B -> ()
+end;;
+[%%expect{|
+Line _, characters 6-110:
+ ......struct
+ type 'a t = A of 'a | B
+
+ let f (x : _ t) =
+ match x with
+ | A _ -> ()
+ | B -> ()
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig type 'a t = 'a B.t = A of 'a | B val f : 'a t -> unit end
+ is not included in
+ sig type 'a t = 'a end
+ Type declarations do not match:
+ type 'a t = 'a B.t = A of 'a | B
+ is not included in
+ type 'a t = 'a
+|}];;
+
+module rec C : sig
+ type 'a t = { x : 'a }
+end = struct
+ type 'a t = A of 'a | B
+
+ let f (x : _ t) =
+ match x with
+ | A _ -> ()
+ | B -> ()
+end;;
+[%%expect{|
+Line _, characters 6-110:
+ ......struct
+ type 'a t = A of 'a | B
+
+ let f (x : _ t) =
+ match x with
+ | A _ -> ()
+ | B -> ()
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig type 'a t = 'a C.t = A of 'a | B val f : 'a t -> unit end
+ is not included in
+ sig type 'a t = { x : 'a; } end
+ Type declarations do not match:
+ type 'a t = 'a C.t = A of 'a | B
+ is not included in
+ type 'a t = { x : 'a; }
+ Their kinds differ.
+|}];;
+
+
+module rec D : sig
+ type 'a t = int
+end = struct
+ type 'a t = A of 'a | B
+
+ let f (x : _ t) =
+ match x with
+ | A _ -> ()
+ | B -> ()
+end;;
+[%%expect{|
+Line _, characters 6-110:
+ ......struct
+ type 'a t = A of 'a | B
+
+ let f (x : _ t) =
+ match x with
+ | A _ -> ()
+ | B -> ()
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig type 'a t = 'a D.t = A of 'a | B val f : 'a t -> unit end
+ is not included in
+ sig type 'a t = int end
+ Type declarations do not match:
+ type 'a t = 'a D.t = A of 'a | B
+ is not included in
+ type 'a t = int
+|}];;
+
+module rec E : sig
+ type 'a t = [> `Foo ] as 'a
+end = struct
+ type 'a t = A of 'a | B
+
+ let f (x : _ t) =
+ match x with
+ | A _ -> ()
+ | B -> ()
+end;;
+[%%expect{|
+Line _, characters 6-110:
+ ......struct
+ type 'a t = A of 'a | B
+
+ let f (x : _ t) =
+ match x with
+ | A _ -> ()
+ | B -> ()
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig type 'a t = 'a E.t = A of 'a | B val f : 'a t -> unit end
+ is not included in
+ sig type 'a t = 'a constraint 'a = [> `Foo ] end
+ Type declarations do not match:
+ type 'a t = 'a E.t = A of 'a | B
+ is not included in
+ type 'a t = 'a constraint 'a = [> `Foo ]
+|}];;
+
+module rec E2 : sig
+ type 'a t = [ `Foo ]
+end = struct
+ type 'a t = A of 'a | B
+
+ let f (x : _ t) =
+ match x with
+ | A _ -> ()
+ | B -> ()
+end;;
+[%%expect{|
+Line _, characters 6-110:
+ ......struct
+ type 'a t = A of 'a | B
+
+ let f (x : _ t) =
+ match x with
+ | A _ -> ()
+ | B -> ()
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig type 'a t = 'a E2.t = A of 'a | B val f : 'a t -> unit end
+ is not included in
+ sig type 'a t = [ `Foo ] end
+ Type declarations do not match:
+ type 'a t = 'a E2.t = A of 'a | B
+ is not included in
+ type 'a t = [ `Foo ]
+|}];;
+
+module rec E3 : sig
+ type 'a t = [< `Foo ] as 'a
+end = struct
+ type 'a t = A of 'a | B
+
+ let f (x : _ t) =
+ match x with
+ | A _ -> ()
+ | B -> ()
+end;;
+[%%expect{|
+Line _, characters 6-110:
+ ......struct
+ type 'a t = A of 'a | B
+
+ let f (x : _ t) =
+ match x with
+ | A _ -> ()
+ | B -> ()
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig type 'a t = 'a E3.t = A of 'a | B val f : 'a t -> unit end
+ is not included in
+ sig type 'a t = 'a constraint 'a = [< `Foo ] end
+ Type declarations do not match:
+ type 'a t = 'a E3.t = A of 'a | B
+ is not included in
+ type 'a t = 'a constraint 'a = [< `Foo ]
+|}];;
+
+
+module rec F : sig
+ type ('a, 'b) t = Foo of 'a
+end = struct
+ type ('a, 'b) t = Foo of 'b
+
+ (* this function typechecks properly, which means that we've added the
+ manisfest. *)
+ let coerce : 'a 'b. ('a, 'b) t -> ('a, 'b) F.t = fun x -> x
+end;;
+[%%expect{|
+Line _, characters 6-201:
+ ......struct
+ type ('a, 'b) t = Foo of 'b
+
+ (* this function typechecks properly, which means that we've added the
+ manisfest. *)
+ let coerce : 'a 'b. ('a, 'b) t -> ('a, 'b) F.t = fun x -> x
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig
+ type ('a, 'b) t = ('a, 'b) F.t = Foo of 'b
+ val coerce : ('a, 'b) t -> ('a, 'b) F.t
+ end
+ is not included in
+ sig type ('a, 'b) t = Foo of 'a end
+ Type declarations do not match:
+ type ('a, 'b) t = ('a, 'b) F.t = Foo of 'b
+ is not included in
+ type ('a, 'b) t = Foo of 'a
+ The types for field Foo are not equal.
+|}];;
--- /dev/null
+(* TEST
+ * expect
+*)
+
+type ('a, 'b) eq = Refl : ('a, 'a) eq
+
+type empty = (int, string) eq
+
+type ('a, 'b) t = Left : 'a -> ('a, 'b) t | Right : 'b -> ('a, 'b) t;;
+
+[%%expect{|
+type ('a, 'b) eq = Refl : ('a, 'a) eq
+type empty = (int, string) eq
+type ('a, 'b) t = Left : 'a -> ('a, 'b) t | Right : 'b -> ('a, 'b) t
+|}]
+
+let f1 x =
+ match x with
+ | (None : empty option) -> ()
+;;
+[%%expect {|
+val f1 : empty option -> unit = <fun>
+|}]
+
+let f2 () =
+ match None with
+ | (None : empty option) -> ()
+;;
+[%%expect {|
+val f2 : unit -> unit = <fun>
+|}]
+
+let f3 () =
+ let x = None in
+ match x with
+ | (None : empty option) -> ()
+;;
+[%%expect {|
+val f3 : unit -> unit = <fun>
+|}]
+
+let f1' x =
+ match x with
+ | (None : empty option) -> ()
+ | Some _ -> .
+;;
+[%%expect {|
+val f1' : empty option -> unit = <fun>
+|}]
+
+let f2' () =
+ match None with
+ | (None : empty option) -> ()
+ | Some _ -> .
+;;
+[%%expect {|
+val f2' : unit -> unit = <fun>
+|}]
+
+let f3' () =
+ let x = None in
+ match x with
+ | (None : empty option) -> ()
+ | Some _ -> .
+;;
+[%%expect {|
+val f3' : unit -> unit = <fun>
+|}]
+
+
+let (Left () : (unit, empty) t) = Left ();;
+[%%expect {|
+|}]
+
+let f () =
+ let Left () = (Left () : (unit, empty) t) in
+ ()
+;;
+[%%expect {|
+val f : unit -> unit = <fun>
+|}]
+
+let f () =
+ let (Left () : (unit, empty) t) = Left () in
+ ()
+;;
+[%%expect{|
+val f : unit -> unit = <fun>
+|}]
+
+let f () =
+ match (Left () : (unit, empty) t) with
+ | Left () -> ()
+;;
+[%%expect {|
+val f : unit -> unit = <fun>
+|}]
+
+let f () =
+ match (Left () : (unit, empty) t) with
+ | Left () -> ()
+ | Right _ -> .
+;;
+[%%expect {|
+val f : unit -> unit = <fun>
+|}]
+
+let f () =
+ match Left () with
+ | (Left () : (unit, empty) t) -> ()
+;;
+[%%expect {|
+val f : unit -> unit = <fun>
+|}]
+
+let f () =
+ match Left () with
+ | (Left () : (unit, empty) t) -> ()
+ | (Right _ : (unit, empty) t) -> .
+;;
+[%%expect {|
+val f : unit -> unit = <fun>
+|}]
+(* TEST
+ * expect
+*)
+
(* PR#5835 *)
let f ~x = x + 1;;
f ?x:0;;
[%%expect{|
val f : x:int -> int = <fun>
Line _, characters 5-6:
+ f ?x:0;;
+ ^
Warning 43: the label x is not optional.
- : int = 1
|}];;
foo (fun ?opt () -> ()) ;; (* fails *)
[%%expect{|
Line _, characters 4-23:
+ foo (fun ?opt () -> ()) ;; (* fails *)
+ ^^^^^^^^^^^^^^^^^^^
Error: This function should have type unit -> unit
but its first argument is labelled ?opt
|}];;
--- /dev/null
+constraints.ml
+disambiguate_principality.ml
+inside_out.ml
+labels.ml
+occur_check.ml
+polyvars.ml
+pr6939-flat-float-array.ml
+pr6939-no-flat-float-array.ml
+pr7103.ml
+pr7228.ml
+pr7668_bad.ml
+printing.ml
+records.ml
+variant.ml
+wellfounded.ml
+empty_variant.ml
+(* TEST
+ * expect
+*)
+
(* PR#5907 *)
type 'a t = 'a;;
[%%expect{|
type 'a t = 'a
Line _, characters 42-43:
+ let f (g : 'a list -> 'a t -> 'a) s = g s s;;
+ ^
Error: This expression has type 'a list
but an expression was expected of type 'a t = 'a
The type variable 'a occurs inside 'a list
let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;;
[%%expect{|
Line _, characters 42-43:
+ let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;;
+ ^
Error: This expression has type 'a * 'b
but an expression was expected of type 'a t = 'a
The type variable 'a occurs inside 'a * 'b
+(* TEST
+ * expect
+*)
+
type ab = [ `A | `B ];;
let f (x : [`A]) = match x with #ab -> 1;;
[%%expect{|
type ab = [ `A | `B ]
Line _, characters 32-35:
+ let f (x : [`A]) = match x with #ab -> 1;;
+ ^^^
Error: This pattern matches values of type [? `A | `B ]
but a pattern was expected which matches values of type [ `A ]
The second variant type does not allow tag(s) `B
let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
[%%expect{|
Line _, characters 31-34:
+ let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
+ ^^^
Error: This pattern matches values of type [? `B ]
but a pattern was expected which matches values of type [ `A ]
The second variant type does not allow tag(s) `B
-|}, Principal{|
-Line _, characters 31-34:
-Error: This pattern matches values of type [? `B ]
- but a pattern was expected which matches values of type [ `A ]
- Types for tag `B are incompatible
|}];;
let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
[%%expect{|
Line _, characters 34-36:
+ let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
+ ^^
Error: This pattern matches values of type [? `B ]
but a pattern was expected which matches values of type [ `A ]
The second variant type does not allow tag(s) `B
-|}, Principal{|
-Line _, characters 34-36:
-Error: This pattern matches values of type [? `B ]
- but a pattern was expected which matches values of type [ `A ]
- Types for tag `B are incompatible
|}];;
let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
[%%expect{|
Line _, characters 49-51:
+ let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
+ ^^
Warning 12: this sub-pattern is unused.
val f : [< `A | `B ] -> int = <fun>
|}];;
let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
[%%expect{|
Line _, characters 47-49:
+ let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
+ ^^
Error: This pattern matches values of type [? `C ]
but a pattern was expected which matches values of type [ `A | `B ]
The second variant type does not allow tag(s) `C
|}];;
+(* imported from in poly.ml *)
+type t = A | B;;
+function `A,_ -> 1 | _,A -> 2 | _,B -> 3;;
+function `A,_ -> 1 | _,(A|B) -> 2;;
+function Some `A, _ -> 1 | Some _, A -> 2 | None, A -> 3 | _, B -> 4;;
+function Some `A, A -> 1 | Some `A, B -> 1
+ | Some _, A -> 2 | None, A -> 3 | _, B -> 4;;
+function A, `A -> 1 | A, `B -> 2 | B, _ -> 3;;
+function `A, A -> 1 | `B, A -> 2 | _, B -> 3;;
+function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;;
+function `B,1 -> 1 | _,1 -> 2;;
+function 1,`B -> 1 | 1,_ -> 2;;
+[%%expect {|
+type t = A | B
+- : [> `A ] * t -> int = <fun>
+- : [> `A ] * t -> int = <fun>
+- : [> `A ] option * t -> int = <fun>
+- : [> `A ] option * t -> int = <fun>
+- : t * [< `A | `B ] -> int = <fun>
+- : [< `A | `B ] * t -> int = <fun>
+Line _, characters 0-41:
+ function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(`AnyOtherTag, `AnyOtherTag)
+- : [> `A | `B ] * [> `A | `B ] -> int = <fun>
+Line _, characters 0-29:
+ function `B,1 -> 1 | _,1 -> 2;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(_, 0)
+Line _, characters 21-24:
+ function `B,1 -> 1 | _,1 -> 2;;
+ ^^^
+Warning 11: this match case is unused.
+- : [< `B ] * int -> int = <fun>
+Line _, characters 0-29:
+ function 1,`B -> 1 | 1,_ -> 2;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(0, _)
+Line _, characters 21-24:
+ function 1,`B -> 1 | 1,_ -> 2;;
+ ^^^
+Warning 11: this match case is unused.
+- : int * [< `B ] -> int = <fun>
+|}];;
+
(* PR#6787 *)
let revapply x f = f x;;
let f (x : [`A | `B] as 'a) (y : [> 'a]) = ();;
[%%expect{|
Line _, characters 61-63:
+ let f : ([`A | `B ] as 'a) -> [> 'a] -> unit = fun x (y : [> 'a]) -> ();;
+ ^^
Error: The type 'a does not expand to a polymorphic variant type
Hint: Did you mean `a?
|}]
[%%expect{|
type t = private [> `A of string ]
Line _, characters 0-24:
+ function (`A x : t) -> x;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
-`<some other tag>
+`<some private tag>
- : t -> string = <fun>
|}]
+
+let f = function `AnyOtherTag, _ -> 1 | _, (`AnyOtherTag|`AnyOtherTag') -> 2;;
+[%%expect{|
+Line _, characters 8-76:
+ let f = function `AnyOtherTag, _ -> 1 | _, (`AnyOtherTag|`AnyOtherTag') -> 2;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(`AnyOtherTag', `AnyOtherTag'')
+val f : [> `AnyOtherTag ] * [> `AnyOtherTag | `AnyOtherTag' ] -> int = <fun>
+|}]
--- /dev/null
+(* TEST
+ * flat-float-array
+ ** expect
+*)
+
+let rec x = [| x |]; 1.;;
+[%%expect{|
+Line _, characters 12-19:
+ let rec x = [| x |]; 1.;;
+ ^^^^^^^
+Warning 10: this expression should have type unit.
+Line _, characters 12-23:
+ let rec x = [| x |]; 1.;;
+ ^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+|}];;
+
+let rec x = let u = [|y|] in 10. and y = 1.;;
+[%%expect{|
+Line _, characters 12-32:
+ let rec x = let u = [|y|] in 10. and y = 1.;;
+ ^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+|}];;
--- /dev/null
+(* TEST
+ * no-flat-float-array
+ ** expect
+*)
+
+let rec x = [| x |]; 1.;;
+[%%expect{|
+Line _, characters 12-19:
+ let rec x = [| x |]; 1.;;
+ ^^^^^^^
+Warning 10: this expression should have type unit.
+val x : float = 1.
+|}];;
+
+let rec x = let u = [|y|] in 10. and y = 1.;;
+[%%expect{|
+Line _, characters 16-17:
+ let rec x = let u = [|y|] in 10. and y = 1.;;
+ ^
+Warning 26: unused variable u.
+val x : float = 10.
+val y : float = 1.
+|}];;
+++ /dev/null
-let rec x = [| x |]; 1.;;
-[%%expect{|
-Line _, characters 12-19:
-Warning 10: this expression should have type unit.
-Line _, characters 12-23:
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-|}];;
-
-let rec x = let u = [|y|] in 10. and y = 1.;;
-[%%expect{|
-Line _, characters 12-32:
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-|}];;
+++ /dev/null
-let rec x = [| x |]; 1.;;
-[%%expect{|
-Line _, characters 12-19:
-Warning 10: this expression should have type unit.
-val x : float = 1.
-|}];;
-
-let rec x = let u = [|y|] in 10. and y = 1.;;
-[%%expect{|
-Line _, characters 16-17:
-Warning 26: unused variable u.
-val x : float = 10.
-val y : float = 1.
-|}];;
+(* TEST
+ * expect
+*)
+
type 'a t
type a
let _ = fun (x : a t) -> f x;;
[%%expect{|
Line _, characters 27-28:
+ let _ = fun (x : a t) -> f x;;
+ ^
Error: This expression has type a t but an expression was expected of type
(< .. > as 'a) t
Type a is not compatible with type < .. > as 'a
let _ = fun (x : a t) -> g x;;
[%%expect{|
Line _, characters 27-28:
+ let _ = fun (x : a t) -> g x;;
+ ^
Error: This expression has type a t but an expression was expected of type
([< `b ] as 'a) t
Type a is not compatible with type [< `b ] as 'a
let _ = fun (x : a t) -> h x;;
[%%expect{|
Line _, characters 27-28:
+ let _ = fun (x : a t) -> h x;;
+ ^
Error: This expression has type a t but an expression was expected of type
([> `b ] as 'a) t
Type a is not compatible with type [> `b ] as 'a
+(* TEST
+ * expect
+*)
+
type t = A of {mutable x: int};;
fun (A r) -> r.x <- 42;;
[%%expect{|
[%%expect{|
type t = private A of { mutable x : int; }
Line _, characters 15-16:
+ fun (A r) -> r.x <- 42;;
+ ^
Error: Cannot assign field x of the private type t.A
|}];;
--- /dev/null
+(* TEST
+ * expect
+*)
+
+let partition_map f xs =
+ let rec part left right = function
+ | [] -> List.rev left, List.rev right
+ | x::xs ->
+ match f x with
+ | `Left v -> part (v::left) right xs
+ | `Right v -> part left (v::right) xs
+ in
+ part [] [] xs
+;;
+
+let f xs : (int list * int list) = partition_map (fun x -> if x then `Left ()
+else `Right ()) xs
+;;
+[%%expect{|
+val partition_map :
+ ('a -> [< `Left of 'b | `Right of 'c ]) -> 'a list -> 'b list * 'c list =
+ <fun>
+Line _, characters 35-96:
+ ...................................partition_map (fun x -> if x then `Left ()
+ else `Right ()) xs
+Error: This expression has type unit list * unit list
+ but an expression was expected of type int list * int list
+ Type unit is not compatible with type int
+|}]
--- /dev/null
+(* TEST
+ * expect
+*)
+
+type 'a or_error = string
+
+type ('a, 'b) t_ =
+ | Bar : ('a, 'a or_error) t_
+
+type 'a t = ('a, 'a) t_
+
+let f : type a. a t -> a t = function
+ | Bar -> Bar
+;;
+[%%expect{|
+type 'a or_error = string
+type ('a, 'b) t_ = Bar : ('a, 'a or_error) t_
+type 'a t = ('a, 'a) t_
+val f : 'a t -> 'a t = <fun>
+|}];;
+(* TEST
+ * expect
+*)
+
(* PR#7012 *)
type t = [ 'A_name | `Hi ];;
[%%expect{|
Line _, characters 11-18:
+ type t = [ 'A_name | `Hi ];;
+ ^^^^^^^
Error: The type 'A_name does not expand to a polymorphic variant type
Hint: Did you mean `A_name?
|}];;
+(* TEST
+ * expect
+*)
+
(* undefined labels *)
type t = {x:int;y:int};;
{x=3;z=2};;
[%%expect{|
type t = { x : int; y : int; }
Line _, characters 5-6:
+ {x=3;z=2};;
+ ^
Error: Unbound record field z
|}];;
fun {x=3;z=2} -> ();;
[%%expect{|
Line _, characters 9-10:
+ fun {x=3;z=2} -> ();;
+ ^
Error: Unbound record field z
|}];;
{x=3; contents=2};;
[%%expect{|
Line _, characters 6-14:
+ {x=3; contents=2};;
+ ^^^^^^^^
Error: The record field contents belongs to the type 'a ref
but is mixed here with fields of type t
|}];;
[%%expect{|
type u = private { mutable u : int; }
Line _, characters 0-5:
+ {u=3};;
+ ^^^^^
Error: Cannot create values of the private type u
|}];;
fun x -> x.u <- 3;;
[%%expect{|
Line _, characters 11-12:
+ fun x -> x.u <- 3;;
+ ^
Error: Cannot assign field u of the private type u
|}];;
[%%expect{|
type foo = { mutable y : int; }
Line _, characters 17-18:
+ let f (r: int) = r.y <- 3;;
+ ^
Error: This expression has type int but an expression was expected of type
foo
|}];;
type foo = { y : int; z : int; }
type bar = { x : int; }
Line _, characters 20-21:
+ let f (r: bar) = ({ r with z = 3 } : foo)
+ ^
Error: This expression has type bar but an expression was expected of type
foo
|}];;
[%%expect{|
type foo = { x : int; }
Line _, characters 16-21:
+ let r : foo = { ZZZ.x = 2 };;
+ ^^^^^
Error: Unbound module ZZZ
|}];;
(ZZZ.X : int option);;
[%%expect{|
Line _, characters 1-6:
+ (ZZZ.X : int option);;
+ ^^^^^
Error: Unbound module ZZZ
|}];;
let f (x : Complex.t) = x.Complex.z;;
[%%expect{|
Line _, characters 26-35:
+ let f (x : Complex.t) = x.Complex.z;;
+ ^^^^^^^^^
Error: Unbound record field Complex.z
|}];;
{ true with contents = 0 };;
[%%expect{|
Line _, characters 2-6:
+ { true with contents = 0 };;
+ ^^^^
Error: This expression has type bool but an expression was expected of type
'a ref
|}];;
val with_fst : ('a, 'b) t -> 'c -> ('c, 'b) t = <fun>
- : (int, string) t = {fst = 2; snd = ""}
|}];;
+
+(* PR#7695 *)
+type 'a t = { f : 'a; g : 'a };;
+let x = { f = 12; g = 43 };;
+{x with f = "hola"};;
+[%%expect{|
+type 'a t = { f : 'a; g : 'a; }
+val x : int t = {f = 12; g = 43}
+Line _, characters 0-19:
+ {x with f = "hola"};;
+ ^^^^^^^^^^^^^^^^^^^
+Error: This expression has type string t
+ but an expression was expected of type int t
+ Type string is not compatible with type int
+|}]
+(* TEST
+ * expect
+*)
+
(* PR#6394 *)
module rec X : sig
end;;
[%%expect{|
Line _, characters 6-61:
+ ......struct
+ type t = A | B
+ let f = function A | B -> 0
+ end..
Error: Signature mismatch:
Modules do not match:
sig type t = X.t = A | B val f : t -> int end
+(* TEST
+ * expect
+*)
+
(* PR#6768 *)
type _ prod = Prod : ('a * 'y) prod;;
[%%expect{|
type _ prod = Prod : ('a * 'y) prod
Line _, characters 6-20:
+ type d = d * d
+ ^^^^^^^^^^^^^^
Error: The type abbreviation d is cyclic
|}];;
+++ /dev/null
-# Tests for compilation with missing cmis
-# main.ml: error message when equality is missing
-# main_ok.ml: allow path expansion even when the target is missing (GPR#816)
-
-SOURCES = subdir/m.ml a.ml b.ml c.ml main.ml main_ok.ml
-
-.PHONY: default
-default: $(SOURCES)
- @printf " ... testing 'main.ml'";
- @$(OCAMLC) -c subdir/m.ml;
- @$(OCAMLC) -c -I subdir a.ml;
- @$(OCAMLC) -c -I subdir b.ml;
- @$(OCAMLC) -c -I subdir c.ml;
- @$(OCAMLC) -c main.ml > main.ml.result 2>&1 || :
- @$(DIFF) main.ml.result main.ml.reference >/dev/null \
- && echo " => passed" || echo " => failed"
- @printf " ... testing 'main_ok.ml'";
- @$(OCAMLC) -c main_ok.ml && echo " => passed" || echo " => failed"
-
-.PHONY: clean
-clean:
- @rm -f subdir/m.cm[io] *.cm[io] main.ml.result
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+File "main.ml", line 1, characters 14-17:
+Error: This expression has type M.b but an expression was expected of type
+ M.a
+M.b is abstract because no corresponding cmi file was found in path.
+M.a is abstract because no corresponding cmi file was found in path.
--- /dev/null
+(* TEST
+files = "a.ml b.ml c.ml main.ml main_ok.ml"
+* setup-ocamlc.byte-build-env
+** script
+script = "mkdir -p subdir"
+*** script
+script = "cp ${test_source_directory}/subdir/m.ml subdir"
+**** ocamlc.byte
+module = "subdir/m.ml"
+***** ocamlc.byte
+flags = "-I subdir"
+module = "a.ml"
+****** ocamlc.byte
+module = "b.ml"
+******* ocamlc.byte
+module = "c.ml"
+******** ocamlc.byte
+flags = ""
+module = "main_ok.ml"
+********* ocamlc.byte
+module = "main.ml"
+ocamlc_byte_exit_status = "2"
+********** check-ocamlc.byte-output
+*)
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module Std = struct module Hash = Hashtbl end;;
open Std;;
--- /dev/null
+gatien_baron_20131019_ok.ml
+pr5164_ok.ml
+pr51_ok.ml
+pr5663_ok.ml
+pr5914_ok.ml
+pr6240_ok.ml
+pr6293_bad.ml
+pr6427_bad.ml
+pr6485_ok.ml
+pr6513_ok.ml
+pr6572_ok.ml
+pr6651_ok.ml
+pr6752_bad.ml
+pr6752_ok.ml
+pr6899_first_bad.ml
+pr6899_ok.ml
+pr6899_second_bad.ml
+pr6944_ok.ml
+pr6954_ok.ml
+pr6981_ok.ml
+pr6982_ok.ml
+pr6985_ok.ml
+pr6992_bad.ml
+pr7036_ok.ml
+pr7082_ok.ml
+pr7112_bad.ml
+pr7112_ok.ml
+pr7152_ok.ml
+pr7182_ok.ml
+pr7305_principal.ml
+pr7321_ok.ml
+pr7414_bad.ml
+pr7414_2_bad.ml
+pr7519_ok.ml
+pr7601_ok.ml
+pr7601a_ok.ml
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type INCLUDING = sig
include module type of List
include module type of ListLabels
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module X=struct
module type SIG=sig type t=int val x:t end
module F(Y:SIG) : SIG = struct type t=Y.t let x=Y.x end
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module F (M : sig
type 'a t
type 'a u = string
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
type 't a = [ `A ]
type 't wrap = 't constraint 't = [> 't wrap a ]
type t = t a wrap
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module M : sig
module type T
module F (X : T) : sig end
--- /dev/null
+File "pr6293_bad.ml", line 10, characters 6-38:
+Error: In this `with' constraint, the new definition of t
+ does not match its original definition in the constrained signature:
+ Type declarations do not match:
+ type t
+ is not included in
+ type t = { a : int; b : int; }
+ File "pr6293_bad.ml", line 9, characters 20-50: Expected declaration
+ File "pr6293_bad.ml", line 10, characters 6-38: Actual declaration
+ Their kinds differ.
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type S = sig type t = { a : int; b : int; } end;;
let f (module M : S with type t = int) = { M.a = 0 };;
--- /dev/null
+File "pr6427_bad.ml", line 12, characters 13-65:
+Error: This expression creates fresh types.
+ It is not allowed inside applicative functors.
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
let flag = ref false
module F(S : sig module type T end) (A : S.T) (B : S.T) =
struct
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(** Check that rebinding module preserves private type aliases *)
module String_id : sig
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type PR6513 = sig
module type S = sig type u end
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type S = sig
include Set.S
module E : sig val x : int end
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type S = sig
module type T
module X : T
--- /dev/null
+File "pr6752_bad.ml", line 26, characters 31-40:
+Error: This expression has type 'a Queue.t
+ but an expression was expected of type Common0.msg Queue.t
+ The type constructor Common0.msg would escape its scope
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Sorry, we have to disable this as this requires accepting
potentially badly formed programs (after expliciting) *)
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Adding a type annotation is sufficient to make typing go through *)
module Common0 =
--- /dev/null
+File "pr6899_first_bad.ml", line 9, characters 4-17:
+Error: The type of this expression, '_weak1 -> '_weak2 -> unit,
+ contains type variables that cannot be generalized
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
let should_reject =
let table = Hashtbl.create 1 in
fun x y -> Hashtbl.add table x y
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
type 'a t = 'a option
let is_some = function
| None -> false
--- /dev/null
+File "pr6899_second_bad.ml", line 12, characters 6-9:
+Error: The type of this expression, _[< `Test ] -> unit,
+ contains type variables that cannot be generalized
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
include struct
let foo `Test = ()
let wrap f `Test = f
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
let f () =
let module S = String in
let module N = Map.Make(S) in
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module X = struct module Y = struct module type S = sig type t end end end
(* open X (* works! *) *)
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type S =
sig
type a
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module A = struct
module type A_S = sig
end
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module Foo
(Bar : sig type a = private [> `A ] end)
(Baz : module type of struct include Bar end) =
--- /dev/null
+File "pr6992_bad.ml", line 16, characters 69-71:
+Error: This expression has type (a, a) eq
+ but an expression was expected of type (a, b) eq
+ Type a is not compatible with type b
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* PR#6992, reported by Stephen Dolan *)
type (_, _) eq = Eq : ('a, 'a) eq
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module M = struct
module type S = sig type a val v : a end
type 'a s = (module S with type a = 'a)
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type FOO = sig type t end
module type BAR =
sig
--- /dev/null
+File "pr7112_bad.ml", line 13, characters 30-31:
+Error: Signature mismatch:
+ Modules do not match: F(N).S is not included in A.S
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module A = struct module type S module S = struct end end
module F (_ : sig end) = struct module type S module S = A.S end
module M = struct end
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module F (_ : sig end) = struct module type S end
module M = struct end
module N = M
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module M : sig
type make_dec
val add_dec: make_dec -> unit
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module rec M
: sig external f : int -> int = "%identity" end
= struct external f : int -> int = "%identity" end
+(* TEST
+flags = " -principal -w +18+19 -warn-error A "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
type c1 = < c1: c1 >
type c2 = < c1: c1; c2: c1; c3: c1; c4: c1; c5: c1; c6: c1 >
type c3 = < c1: c2; c2: c2; c3: c2; c4: c2; c5: c2; c6: c2 >
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type S = sig type 'a t end
module type Sp = sig type 'a t = private 'a array end
--- /dev/null
+File "pr7414_2_bad.ml", line 46, characters 28-34:
+Error: Signature mismatch:
+ Modules do not match:
+ functor () -> sig module Choice : T val r : '_weak1 list ref ref end
+ is not included in
+ functor () -> S
+ At position functor () -> <here>
+ Modules do not match:
+ sig module Choice : T val r : '_weak1 list ref ref end
+ is not included in
+ S
+ At position functor () -> <here>
+ Values do not match:
+ val r : '_weak1 list ref ref
+ is not included in
+ val r : Choice.t list ref ref
+ File "pr7414_2_bad.ml", line 29, characters 2-31: Expected declaration
+ File "pr7414_2_bad.ml", line 40, characters 8-9: Actual declaration
--- /dev/null
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
+module type T = sig
+ type t
+ val x : t
+ val show : t -> string
+end
+
+module Int = struct
+ type t = int
+ let x = 0
+ let show x = string_of_int x
+end
+
+module String = struct
+ type t = string
+ let x = "Hello"
+ let show x = x
+end
+
+module type S = sig
+ module Choice : T
+ val r : Choice.t list ref ref
+end
+
+module Force (X : functor () -> S) = struct end
+
+let () =
+ let switch = ref true in
+ let module Choose () = struct
+ module Choice =
+ (val if !switch then (module Int : T)
+ else (module String : T))
+ let r = ref (ref [])
+ end in
+ let module M = Choose () in
+ let () = switch := false in
+ let module N = Choose () in
+ let () = N.r := !M.r in
+ let module Ignore = Force(Choose) in
+ let module M' = (M : S) in
+ let () = (!M'.r) := [M'.Choice.x] in
+ let module N' = (N : S) in
+ List.iter (fun x -> print_string (N'.Choice.show x)) !(!N'.r)
--- /dev/null
+File "pr7414_bad.ml", line 52, characters 22-28:
+Error: Signature mismatch:
+ Modules do not match:
+ functor () -> sig module Choice : T val r : '_weak1 list ref ref end
+ is not included in
+ functor () -> S
+ At position functor () -> <here>
+ Modules do not match:
+ sig module Choice : T val r : '_weak1 list ref ref end
+ is not included in
+ S
+ At position functor () -> <here>
+ Values do not match:
+ val r : '_weak1 list ref ref
+ is not included in
+ val r : Choice.t list ref ref
+ File "pr7414_bad.ml", line 38, characters 2-31: Expected declaration
+ File "pr7414_bad.ml", line 33, characters 6-7: Actual declaration
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type T = sig
type t
val x : t
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module Gen_spec = struct type 't extra = unit end
module type S = sig
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(**************************************************************************)
(* *)
(* Crude slicer for preprocessing reachability verification tasks *)
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type Param1 = sig
type 'a r = [< `A of int ] as 'a
val f : ?a:string -> string -> [ `A of _ ] r
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.expect
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * expect
+*)
+
(* with module *)
module type S = sig type t and s = t end;;
;;
[%%expect{|
Line _, characters 2-37:
+ struct type +'a t = private int end
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
Modules do not match:
sig type +'a t = private int end
module type A = sig type t = X of int end
type u = X of bool
Line _, characters 23-33:
+ module type B = A with type t = u;; (* fail *)
+ ^^^^^^^^^^
Error: This variant or record definition does not match that of type u
The types for field X are not equal.
|}];;
module type S = sig exception Foo of int exception Foo of bool end;;
[%%expect{|
Line _, characters 52-55:
+ module type S = sig exception Foo of int exception Foo of bool end;;
+ ^^^
Error: Multiple definition of the extension constructor name Foo.
Names must be unique in a given structure or signature.
|}];;
[%%expect{|
module F : functor (X : sig end) -> sig val x : int end
Line _, characters 0-3:
-Error: The module F is a functor, not a structure
+ F.x;; (* fail *)
+ ^^^
+Error: The module F is a functor, it cannot have any components
|}];;
+(* TEST
+ * expect
+*)
+
module C = Char;;
C.chr 66;;
val find_last : (elt -> bool) -> t -> elt
val find_last_opt : (elt -> bool) -> t -> elt option
val of_list : elt list -> t
+ val to_seq_from : elt -> t -> elt Seq.t
+ val to_seq : t -> elt Seq.t
+ val add_seq : elt Seq.t -> t -> t
+ val of_seq : elt Seq.t -> t
end
module SSet :
sig
val find_last : (elt -> bool) -> t -> elt
val find_last_opt : (elt -> bool) -> t -> elt option
val of_list : elt list -> t
+ val to_seq_from : elt -> t -> elt Seq.t
+ val to_seq : t -> elt Seq.t
+ val add_seq : elt Seq.t -> t -> t
+ val of_seq : elt Seq.t -> t
end
val f : StringSet.t -> SSet.t = <fun>
|}];;
val find_last : (elt -> bool) -> t -> elt
val find_last_opt : (elt -> bool) -> t -> elt option
val of_list : elt list -> t
+ val to_seq_from : elt -> t -> elt Seq.t
+ val to_seq : t -> elt Seq.t
+ val add_seq : elt Seq.t -> t -> t
+ val of_seq : elt Seq.t -> t
end
val empty : S.t
end
module L1 = struct module X = A1 end
module L2 = struct module X = A2 end;;
-module F (L : (module type of L1)) = struct end;;
+module F (L : (module type of L1 [@remove_aliases])) = struct end;;
module F1 = F(L1);; (* ok *)
module F2 = F(L2);; (* should succeed too *)
module I = Int
type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
end;;
-module type S = module type of M;; (* keep alias *)
+module type S = module type of M [@remove_aliases];; (* keep alias *)
module Int2 = struct type t = int let compare x y = compare y x end;;
module type S' = sig
val find_last : (elt -> bool) -> t -> elt
val find_last_opt : (elt -> bool) -> t -> elt option
val of_list : elt list -> t
+ val to_seq_from : elt -> t -> elt Seq.t
+ val to_seq : t -> elt Seq.t
+ val add_seq : elt Seq.t -> t -> t
+ val of_seq : elt Seq.t -> t
end
type (_, _) eq = Eq : ('a, 'a) eq
type wrap = W of (SInt.t, SInt.t) eq
end
module Int2 : sig type t = int val compare : 'a -> 'a -> int end
Line _, characters 10-30:
+ include S with module I := I
+ ^^^^^^^^^^^^^^^^^^^^
Error: In this `with' constraint, the new definition of I
does not match its original definition in the constrained signature:
Modules do not match: (module Int2) is not included in (module Int)
type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq
end
end;;
-module type S = module type of M ;;
+module type S = module type of M [@remove_aliases];;
[%%expect{|
module M :
sig
type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq
end
end;;
-module type S = module type of M ;;
+module type S = module type of M [@remove_aliases];;
[%%expect{|
module M :
sig
module rec R : sig module M = M end
- : int = 3
|}];;
+
+module M = struct type t end
+module type S = sig module N = M val x : N.t end
+module type T = S with module N := M;;
+[%%expect{|
+module M : sig type t end
+module type S = sig module N = M val x : N.t end
+module type T = sig val x : M.t end
+|}];;
+
+
+module X = struct module N = struct end end
+module Y : sig
+ module type S = sig module N = X.N end
+end = struct
+ module type S = module type of struct include X end
+end;;
+[%%expect{|
+module X : sig module N : sig end end
+module Y : sig module type S = sig module N = X.N end end
+|}];;
--- /dev/null
+(* TEST
+ * expect
+*)
+
+type t = Set.Make(String).t
+[%%expect{|
+type t = Set.Make(String).t
+|} ]
+
+
+(* Check the error messages of an ill-typed applicatived functor type. *)
+module M = struct type t let equal = (=) end
+[%%expect{|
+module M : sig type t val equal : 'a -> 'a -> bool end
+|} ]
+
+type t = Set.Make(M).t
+[%%expect{|
+Line _, characters 9-22:
+ type t = Set.Make(M).t
+ ^^^^^^^^^^^^^
+Error: The type of M does not match Set.Make's parameter
+ Modules do not match:
+ sig type t = M.t val equal : 'a -> 'a -> bool end
+ is not included in
+ Set.OrderedType
+ The value `compare' is required but not provided
+ File "set.mli", line 52, characters 4-31: Expected declaration
+|} ]
+
+
+(* We would report the wrong error here if we didn't strengthen the
+ type of the argument (type t wouldn't match). *)
+module F(X : sig type t = M.t val equal : unit end)
+ = struct type t end
+[%%expect{|
+module F :
+ functor (X : sig type t = M.t val equal : unit end) -> sig type t end
+|} ]
+
+type t = F(M).t
+[%%expect{|
+Line _, characters 9-15:
+ type t = F(M).t
+ ^^^^^^
+Error: The type of M does not match F's parameter
+ Modules do not match:
+ sig type t = M.t val equal : 'a -> 'a -> bool end
+ is not included in
+ sig type t = M.t val equal : unit end
+ Values do not match:
+ val equal : 'a -> 'a -> bool
+ is not included in
+ val equal : unit
+|} ]
+
+
+(* MPR#7611 *)
+module Generative() = struct type t end
+[%%expect{|
+module Generative : functor () -> sig type t end
+|}]
+
+type t = Generative(M).t
+[%%expect{|
+Line _, characters 9-24:
+ type t = Generative(M).t
+ ^^^^^^^^^^^^^^^
+Error: The functor Generative is generative, it cannot be applied in type
+ expressions
+|}]
+
+
+
+module F(X : sig module type S module F : S end) = struct
+ type t = X.F(Parsing).t
+end
+[%%expect{|
+Line _, characters 11-25:
+ type t = X.F(Parsing).t
+ ^^^^^^^^^^^^^^
+Error: The module X.F is abstract, it cannot be applied
+|}]
+(* TEST
+ * expect
+*)
+
module type S = sig type u type t end;;
module type S' = sig type t = int type u = bool end;;
<fun>
val h : (module S2 with type t = 'a) -> (module S with type t = 'a) = <fun>
Line _, characters 3-4:
+ (x : (module S'));; (* fail *)
+ ^
Error: This expression has type
(module S2 with type t = int and type u = bool)
but an expression was expected of type (module S')
[%%expect{|
module type S3 = sig type u type t val x : int end
Line _, characters 2-67:
+ (x : (module S3 with type t = 'a and type u = 'b) :> (module S'));; (* fail *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Type (module S3 with type t = int and type u = bool)
is not a subtype of (module S')
|}];;
+(* TEST
+ * expect
+*)
+
(* Using generative functors *)
(* Without type *)
module G (X : sig end) : S = F ();; (* fail *)
[%%expect{|
Line _, characters 29-33:
+ module G (X : sig end) : S = F ();; (* fail *)
+ ^^^^
Error: This expression creates fresh types.
It is not allowed inside applicative functors.
|}];;
module M = F(U);; (* fail *)
[%%expect{|
Line _, characters 11-12:
+ module M = F(U);; (* fail *)
+ ^
Error: This is a generative functor. It can only be applied to ()
|}];;
[%%expect{|
module F1 : functor (X : sig end) -> sig end
Line _, characters 36-38:
+ module F2 : functor () -> sig end = F1;; (* fail *)
+ ^^
Error: Signature mismatch:
Modules do not match:
functor (X : sig end) -> sig end
[%%expect{|
module F3 : functor () -> sig end
Line _, characters 47-49:
+ module F4 : functor (X : sig end) -> sig end = F3;; (* fail *)
+ ^^
Error: Signature mismatch:
Modules do not match:
functor () -> sig end
--- /dev/null
+aliases.ml
+applicative_functor_type.ml
+firstclass.ml
+generative.ml
+pr5911.ml
+pr6394.ml
+pr7207.ml
+pr7348.ml
+pr7787.ml
+printing.ml
+recursive.ml
+Test.ml
+(* TEST
+ * expect
+*)
+
module type S = sig
type t
val x : t
--- /dev/null
+(* TEST
+ * expect
+*)
+
+[@@@ ocaml.warning "+4"]
+module rec X : sig
+ type t = int * bool
+end = struct
+ type t = A | B
+ let f = function A | B -> 0
+end;;
+[%%expect{|
+Line _, characters 6-63:
+ ......struct
+ type t = A | B
+ let f = function A | B -> 0
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig type t = X.t = A | B val f : t -> int end
+ is not included in
+ sig type t = int * bool end
+ Type declarations do not match:
+ type t = X.t = A | B
+ is not included in
+ type t = int * bool
+|}];;
+(* TEST
+ * expect
+*)
+
module F (X : sig end) = struct type t = int end;;
type t = F(Does_not_exist).t;;
[%%expect{|
module F : functor (X : sig end) -> sig type t = int end
Line _, characters 9-28:
+ type t = F(Does_not_exist).t;;
+ ^^^^^^^^^^^^^^^^^^^
Error: Unbound module Does_not_exist
|}];;
+(* TEST
+ * expect
+*)
+
module F (X : sig type t = private < foo:int; ..> val x : t end) = struct
let x : < foo: int; ..> = X.x
end;;
--- /dev/null
+(* TEST
+ * expect
+*)
+
+module O (T : sig
+ module N : sig
+ val foo : int -> int
+ end
+ end) = struct
+ open T
+
+ let go () =
+ N.foo 42 (* finding N (from T) goes wrong *)
+end
+
+module T = struct
+ module N = struct
+ let foo x = x + 3
+ end
+end;;
+[%%expect{|
+module O :
+ functor (T : sig module N : sig val foo : int -> int end end) ->
+ sig val go : unit -> int end
+module T : sig module N : sig val foo : int -> int end end
+|}]
+
+(* Incidentally, M isn't used in T2, but it doesn't seem to fail if
+ it's just "module M" and "module T2" separately *)
+module rec M : sig
+ val go : unit -> int
+end = O (T2)
+and T2 : sig
+ include module type of struct include T end
+end = struct
+ include T
+end;;
+[%%expect{|
+module rec M : sig val go : unit -> int end
+and T2 : sig module N = T.N end
+|}]
+
+let () = ignore (M.go ())
+[%%expect{|
+|}]
+(* TEST
+ * expect
+*)
+
(* PR#6650 *)
module type S = sig
+(* TEST
+ * expect
+*)
+
(* PR#7324 *)
module rec T : sig type t = T.t end = T;;
[%%expect{|
Line _, characters 15-35:
+ module rec T : sig type t = T.t end = T;;
+ ^^^^^^^^^^^^^^^^^^^^
Error: The type abbreviation T.t is cyclic
|}]
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-GENERATED= a.ml b.ml c.ml d.mli e.ml f.ml g.ml test
-
-default: pr7325 pr6372 pr7563
-
-pr7325:
- @printf " ... testing 'pr7325':"
- @echo "type _ t = T" > a.ml
- @echo "type 'a t = 'a A.t" > b.ml
- @echo 'external f : unit -> unit B.t = "%identity"' > c.ml
- @$(OCAMLC) -c a.ml b.ml && rm a.cmi && $(OCAMLC) -c c.ml \
- && echo " => passed" || echo " => failed"
-
-pr6372:
- @printf " ... testing 'pr6372':"
- @echo "type _ t = C: { f: ('a -> [<\`X]) t } -> [<\`X] t" > d.mli
- @echo "open D;; let f (C {f}) = ()" > e.ml
- @$(OCAMLC) -c d.mli e.ml \
- && echo " => passed" || echo " => failed"
-
-pr7563:
- @printf " ... testing 'pr7563':"
- @echo "module A = struct end" > f.ml
- @echo "module Alias = A" >> f.ml
- @echo "exception Alias" >> f.ml
- @echo "let alias = Alias" >> f.ml
- @echo "exit (if F.Alias = F.alias then 0 else 1)" > g.ml
- @$(OCAMLC) f.ml g.ml -o test && $(OCAMLRUN) ./test \
- && echo " => passed" || echo " => failed"
-
-clean: defaultclean
- @rm -f $(GENERATED)
-
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+type _ t = T
--- /dev/null
+type 'a t = 'a A.t
--- /dev/null
+external f : unit -> unit B.t = "%identity"
--- /dev/null
+type _ t = C: { f: ('a -> [<`X]) t } -> [<`X] t
--- /dev/null
+open D;; let f (C {f}) = ()
--- /dev/null
+module A = struct end
+module Alias = A
+exception Alias
+let alias = Alias
--- /dev/null
+pr6372.ml
+pr7325.ml
+pr7563.ml
--- /dev/null
+(* TEST
+files = "d.mli e.ml"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+module = "d.mli"
+*** ocamlc.byte
+module = "e.ml"
+**** check-ocamlc.byte-output
+*)
--- /dev/null
+(* TEST
+files = "a.ml b.ml c.ml"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+module = "a.ml"
+*** ocamlc.byte
+module = "b.ml"
+**** script
+script = "rm a.cmi"
+***** ocamlc.byte
+module = "c.ml"
+****** check-ocamlc.byte-output
+*)
\ No newline at end of file
--- /dev/null
+(* TEST
+modules = "f.ml"
+*)
+
+exit (if F.Alias = F.alias then 0 else 1)
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.okbad
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+pr3968_bad.ml
+pr4018_bad.ml
+pr4435_bad.ml
+pr4766_ok.ml
+pr4824_ok.ml
+pr4824a_bad.ml
+pr5156_ok.ml
+pr7284_bad.ml
+pr7293_ok.ml
+woodyatt_ok.ml
+yamagata021012_ok.ml
--- /dev/null
+File "pr3968_bad.ml", line 20, characters 0-165:
+Error: The class type
+ object
+ val l :
+ [ `Abs of
+ string *
+ ([ `Abs of string * expr | `App of 'a * exp ] as 'b)
+ | `App of expr * expr ] as 'a
+ val r : exp
+ method eval : (string, exp) Hashtbl.t -> 'b
+ end
+ is not matched by the class type exp
+ The class type
+ object
+ val l :
+ [ `Abs of
+ string *
+ ([ `Abs of string * expr | `App of 'a * exp ] as 'b)
+ | `App of expr * expr ] as 'a
+ val r : exp
+ method eval : (string, exp) Hashtbl.t -> 'b
+ end
+ is not matched by the class type
+ object method eval : (string, exp) Hashtbl.t -> expr end
+ The method eval has type
+ (string, exp) Hashtbl.t ->
+ ([ `Abs of string * expr
+ | `App of [ `Abs of string * 'a | `App of expr * expr ] * exp ]
+ as 'a)
+ but is expected to have type (string, exp) Hashtbl.t -> expr
+ Type
+ [ `Abs of string * expr
+ | `App of [ `Abs of string * 'a | `App of expr * expr ] * exp ]
+ as 'a
+ is not compatible with type
+ expr = [ `Abs of string * expr | `App of expr * expr ]
+ Type exp = < eval : (string, exp) Hashtbl.t -> expr >
+ is not compatible with type
+ expr = [ `Abs of string * expr | `App of expr * expr ]
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
type expr =
[ `Abs of string * expr
| `App of expr * expr
--- /dev/null
+File "pr4018_bad.ml", line 42, characters 11-17:
+Error: This type entity = < destroy_subject : id subject; entity_id : id >
+ should be an instance of type
+ < destroy_subject : < add_observer : 'a entity_container -> 'c; .. >
+ as 'b;
+ .. >
+ as 'a
+ Type
+ id subject =
+ < add_observer : (id subject, id) observer -> unit;
+ notify_observers : id -> unit >
+ is not compatible with type
+ < add_observer : 'a entity_container -> 'c; .. > as 'b
+ Type (id subject, id) observer = < notify : id subject -> id -> unit >
+ is not compatible with type
+ 'a entity_container =
+ < add_entity : (< destroy_subject : < add_observer : 'a
+ entity_container ->
+ 'e;
+ .. >;
+ .. >
+ as 'd) ->
+ 'e;
+ notify : 'd -> id -> unit >
+ Type < destroy_subject : id subject; entity_id : id >
+ is not compatible with type
+ entity = < destroy_subject : id subject; entity_id : id >
+ Type
+ < add_observer : (id subject, id) observer -> unit;
+ notify_observers : id -> unit >
+ is not compatible with type
+ id subject =
+ < add_observer : (id subject, id) observer -> unit;
+ notify_observers : id -> unit >
+ Type < add_entity : 'd -> 'e; notify : 'd -> id -> unit >
+ is not compatible with type
+ 'a entity_container =
+ < add_entity : 'd -> 'e; notify : 'd -> id -> unit >
+ Type < notify : id subject -> id -> unit > is not compatible with type
+ (id subject, id) observer = < notify : id subject -> id -> unit >
+ Types for method add_entity are incompatible
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
class virtual ['subject, 'event] observer =
object
--- /dev/null
+File "pr4435_bad.ml", line 14, characters 6-7:
+Error: Multiple definition of the type name c.
+ Names must be unique in a given structure or signature.
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Two v's in the same class *)
class c v = object initializer print_endline v val v = 42 end;;
new c "42";;
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
class virtual ['a] c =
object (s : 'a)
method virtual m : 'b
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module M :
sig
class x : int -> object method m : int end
--- /dev/null
+File "pr4824a_bad.ml", line 10, characters 2-45:
+Error: Signature mismatch:
+ ...
+ Class declarations do not match:
+ class c : 'a -> object val x : 'a end
+ does not match
+ class c : 'a -> object val x : 'b end
+ The instance variable x has type 'a but is expected to have type 'b
+ This instance of 'b is ambiguous:
+ it would escape the scope of its equation
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module M : sig class c : 'a -> object val x : 'b end end =
struct class c x = object val x = x end end
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
class type t = object end;;
class ['a] o1 = object (self : #t as 'a) end;;
type 'a obj = ( < .. > as 'a);;
--- /dev/null
+File "pr7284_bad.ml", line 35, characters 30-62:
+Error (warning 8): this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+V2 _
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type S = sig
type o1 = < bar : int; foo : int >
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
type t = T : t
type s = T
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* test.ml *)
class alfa = object(_:'self)
method x: 'a. ('a, out_channel, unit) format -> 'a = Printf.printf
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* The module begins *)
exception Out_of_range
+(* TEST
+ * expect
+*)
class point x_init = object
val mutable x = x_init
method get_x = x
method move d = x <- x + d
end;;
+[%%expect{|
+class point :
+ int ->
+ object val mutable x : int method get_x : int method move : int -> unit end
+|}];;
let p = new point 7;;
+[%%expect{|
+val p : point = <obj>
+|}];;
p#get_x;;
+[%%expect{|
+- : int = 7
+|}];;
p#move 3;;
+[%%expect{|
+- : unit = ()
+|}];;
p#get_x;;
+[%%expect{|
+- : int = 10
+|}];;
let q = Oo.copy p;;
+[%%expect{|
+val q : point = <obj>
+|}, Principal{|
+val q : < get_x : int; move : int -> unit > = <obj>
+|}];;
q#move 7; p#get_x, q#get_x;;
+[%%expect{|
+- : int * int = (10, 17)
+|}];;
class color_point x (c : string) = object
inherit point x
val c = c
method color = c
end;;
+[%%expect{|
+class color_point :
+ int ->
+ string ->
+ object
+ val c : string
+ val mutable x : int
+ method color : string
+ method get_x : int
+ method move : int -> unit
+ end
+|}];;
let p' = new color_point 5 "red";;
+[%%expect{|
+val p' : color_point = <obj>
+|}];;
p'#get_x, p'#color;;
+[%%expect{|
+- : int * string = (5, "red")
+|}];;
let l = [p; (p' :> point)];;
+[%%expect{|
+val l : point list = [<obj>; <obj>]
+|}];;
let get_x p = p#get_x;;
+[%%expect{|
+val get_x : < get_x : 'a; .. > -> 'a = <fun>
+|}];;
let set_x p = p#set_x;;
+[%%expect{|
+val set_x : < set_x : 'a; .. > -> 'a = <fun>
+|}];;
List.map get_x l;;
+[%%expect{|
+- : int list = [10; 5]
+|}];;
class ref x_init = object
val mutable x = x_init
method get = x
method set y = x <- y
end;;
+[%%expect{|
+Line _, characters 0-95:
+ class ref x_init = object
+ val mutable x = x_init
+ method get = x
+ method set y = x <- y
+ end..
+Error: Some type variables are unbound in this type:
+ class ref :
+ 'a ->
+ object
+ val mutable x : 'a
+ method get : 'a
+ method set : 'a -> unit
+ end
+ The method get has type 'a where 'a is unbound
+|}];;
class ref (x_init:int) = object
val mutable x = x_init
method get = x
method set y = x <- y
end;;
+[%%expect{|
+class ref :
+ int ->
+ object val mutable x : int method get : int method set : int -> unit end
+|}];;
class ['a] ref x_init = object
val mutable x = (x_init : 'a)
method get = x
method set y = x <- y
end;;
+[%%expect{|
+class ['a] ref :
+ 'a -> object val mutable x : 'a method get : 'a method set : 'a -> unit end
+|}];;
let r = new ref 1 in r#set 2; (r#get);;
+[%%expect{|
+- : int = 2
+|}];;
class ['a] circle (c : 'a) = object
val mutable center = c
method set_center c = center <- c
method move = (center#move : int -> unit)
end;;
+[%%expect{|
+class ['a] circle :
+ 'a ->
+ object
+ constraint 'a = < move : int -> unit; .. >
+ val mutable center : 'a
+ method center : 'a
+ method move : int -> unit
+ method set_center : 'a -> unit
+ end
+|}];;
class ['a] circle (c : 'a) = object
constraint 'a = #point
method set_center c = center <- c
method move = center#move
end;;
+[%%expect{|
+class ['a] circle :
+ 'a ->
+ object
+ constraint 'a = #point
+ val mutable center : 'a
+ method center : 'a
+ method move : int -> unit
+ method set_center : 'a -> unit
+ end
+|}];;
let (c, c') = (new circle p, new circle p');;
+[%%expect{|
+val c : point circle = <obj>
+val c' : color_point circle = <obj>
+|}, Principal{|
+val c : point circle = <obj>
+val c' : < color : string; get_x : int; move : int -> unit > circle = <obj>
+|}];;
class ['a] color_circle c = object
constraint 'a = #color_point
inherit ['a] circle c
method color = center#color
end;;
+[%%expect{|
+class ['a] color_circle :
+ 'a ->
+ object
+ constraint 'a = #color_point
+ val mutable center : 'a
+ method center : 'a
+ method color : string
+ method move : int -> unit
+ method set_center : 'a -> unit
+ end
+|}];;
let c'' = new color_circle p;;
+[%%expect{|
+Line _, characters 27-28:
+ let c'' = new color_circle p;;
+ ^
+Error: This expression has type point but an expression was expected of type
+ #color_point
+ The first object type has no method color
+|}];;
let c'' = new color_circle p';;
+[%%expect{|
+val c'' : color_point color_circle = <obj>
+|}];;
(c'' :> color_point circle);;
-(c'' :> point circle);; (* Fail *)
+[%%expect{|
+- : color_point circle = <obj>
+|}];;
+(c'' :> point circle);;
+[%%expect{|
+Line _, characters 0-21:
+ (c'' :> point circle);;
+ ^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+ color_point color_circle =
+ < center : color_point; color : string; move : int -> unit;
+ set_center : color_point -> unit >
+ is not a subtype of
+ point circle =
+ < center : point; move : int -> unit; set_center : point -> unit >
+ Type point is not a subtype of color_point
+|}];; (* Fail *)
fun x -> (x : color_point color_circle :> point circle);;
+[%%expect{|
+Line _, characters 9-55:
+ fun x -> (x : color_point color_circle :> point circle);;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+ color_point color_circle =
+ < center : color_point; color : string; move : int -> unit;
+ set_center : color_point -> unit >
+ is not a subtype of
+ point circle =
+ < center : point; move : int -> unit; set_center : point -> unit >
+ Type point is not a subtype of color_point
+|}];;
class printable_point y = object (s)
inherit point y
- method print = print_int s#get_x
+ method print = Format.print_int s#get_x
end;;
+[%%expect{|
+class printable_point :
+ int ->
+ object
+ val mutable x : int
+ method get_x : int
+ method move : int -> unit
+ method print : unit
+ end
+|}];;
let p = new printable_point 7;;
+[%%expect{|
+val p : printable_point = <obj>
+|}];;
p#print;;
+[%%expect{|
+- : unit = ()
+|}];;
class printable_color_point y c = object (self)
inherit color_point y c
inherit printable_point y as super
method print =
- print_string "(";
+ Format.print_string "(";
super#print;
- print_string ", ";
- print_string (self#color);
- print_string ")"
+ Format.print_string ", ";
+ Format.print_string (self#color);
+ Format.print_string ")"
end;;
+[%%expect{|
+Line _, characters 10-27:
+ inherit printable_point y as super
+ ^^^^^^^^^^^^^^^^^
+Warning 13: the following instance variables are overridden by the class printable_point :
+ x
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+class printable_color_point :
+ int ->
+ string ->
+ object
+ val c : string
+ val mutable x : int
+ method color : string
+ method get_x : int
+ method move : int -> unit
+ method print : unit
+ end
+|}];;
let p' = new printable_color_point 7 "red";;
+[%%expect{|
+val p' : printable_color_point = <obj>
+|}];;
p'#print;;
+[%%expect{|
+- : unit = ()
+|}];;
class functional_point y = object
val x = y
method get_x = x
method move d = {< x = x + d >}
end;;
+[%%expect{|
+class functional_point :
+ int ->
+ object ('a) val x : int method get_x : int method move : int -> 'a end
+|}];;
let p = new functional_point 7;;
+[%%expect{|
+val p : functional_point = <obj>
+|}];;
p#get_x;;
+[%%expect{|
+- : int = 7
+|}];;
(p#move 3)#get_x;;
+[%%expect{|
+- : int = 10
+|}];;
p#get_x;;
+[%%expect{|
+- : int = 7
+|}];;
fun x -> (x :> functional_point);;
+[%%expect{|
+- : #functional_point -> functional_point = <fun>
+|}];;
(*******************************************************************)
self#tl#iter f
end
method print (f : 'a -> unit) =
- print_string "(";
- self#iter (fun x -> f x; print_string "::");
- print_string "[]";
- print_string ")"
+ Format.print_string "(";
+ self#iter (fun x -> f x; Format.print_string "::");
+ Format.print_string "[]";
+ Format.print_string ")"
end and ['a] nil () = object
inherit ['a] lst ()
method null = true
method hd = h
method tl = t
end;;
+[%%expect{|
+class virtual ['a] lst :
+ unit ->
+ object
+ method virtual hd : 'a
+ method iter : ('a -> unit) -> unit
+ method map : ('a -> 'a) -> 'a lst
+ method virtual null : bool
+ method print : ('a -> unit) -> unit
+ method virtual tl : 'a lst
+ end
+and ['a] nil :
+ unit ->
+ object
+ method hd : 'a
+ method iter : ('a -> unit) -> unit
+ method map : ('a -> 'a) -> 'a lst
+ method null : bool
+ method print : ('a -> unit) -> unit
+ method tl : 'a lst
+ end
+and ['a] cons :
+ 'a ->
+ 'a lst ->
+ object
+ val h : 'a
+ val t : 'a lst
+ method hd : 'a
+ method iter : ('a -> unit) -> unit
+ method map : ('a -> 'a) -> 'a lst
+ method null : bool
+ method print : ('a -> unit) -> unit
+ method tl : 'a lst
+ end
+|}];;
let l1 = new cons 3 (new cons 10 (new nil ()));;
+[%%expect{|
+val l1 : int lst = <obj>
+|}];;
-l1#print print_int;;
+l1#print Format.print_int;;
+[%%expect{|
+- : unit = ()
+|}];;
let l2 = l1#map (fun x -> x + 1);;
-l2#print print_int;;
+[%%expect{|
+val l2 : int lst = <obj>
+|}];;
+l2#print Format.print_int;;
+[%%expect{|
+- : unit = ()
+|}];;
let rec map_list f (x:'a lst) =
if x#null then new nil()
else new cons (f x#hd) (map_list f x#tl);;
+[%%expect{|
+val map_list : ('a -> 'b) -> 'a lst -> 'b lst = <fun>
+|}];;
let p1 = (map_list (fun x -> new printable_color_point x "red") l1);;
+[%%expect{|
+val p1 : printable_color_point lst = <obj>
+|}];;
p1#print (fun x -> x#print);;
+[%%expect{|
+- : unit = ()
+|}];;
(*******************************************************************)
class virtual comparable () = object (self : 'a)
method virtual cmp : 'a -> int
end;;
+[%%expect{|
+class virtual comparable :
+ unit -> object ('a) method virtual cmp : 'a -> int end
+|}];;
class int_comparable (x : int) = object
inherit comparable ()
method x = x
method cmp p = compare x p#x
end;;
+[%%expect{|
+class int_comparable :
+ int -> object ('a) val x : int method cmp : 'a -> int method x : int end
+|}];;
class int_comparable2 xi = object
inherit int_comparable xi
val mutable x' = xi
method set_x y = x' <- y
end;;
+[%%expect{|
+class int_comparable2 :
+ int ->
+ object ('a)
+ val x : int
+ val mutable x' : int
+ method cmp : 'a -> int
+ method set_x : int -> unit
+ method x : int
+ end
+|}];;
class ['a] sorted_list () = object
constraint 'a = #comparable
l <- insert l
method hd = List.hd l
end;;
+[%%expect{|
+class ['a] sorted_list :
+ unit ->
+ object
+ constraint 'a = #comparable
+ val mutable l : 'a list
+ method add : 'a -> unit
+ method hd : 'a
+ end
+|}];;
let l = new sorted_list ();;
+[%%expect{|
+val l : _#comparable sorted_list = <obj>
+|}];;
let c = new int_comparable 10;;
+[%%expect{|
+val c : int_comparable = <obj>
+|}];;
l#add c;;
+[%%expect{|
+- : unit = ()
+|}];;
let c2 = new int_comparable2 15;;
-l#add (c2 :> int_comparable);; (* Fail : 'a comp2 is not a subtype *)
+[%%expect{|
+val c2 : int_comparable2 = <obj>
+|}];;
+l#add (c2 :> int_comparable);;
+[%%expect{|
+Line _, characters 6-28:
+ l#add (c2 :> int_comparable);;
+ ^^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+ int_comparable2 =
+ < cmp : int_comparable2 -> int; set_x : int -> unit; x : int >
+ is not a subtype of
+ int_comparable = < cmp : int_comparable -> int; x : int >
+ Type int_comparable = < cmp : int_comparable -> int; x : int >
+ is not a subtype of
+ int_comparable2 =
+ < cmp : int_comparable2 -> int; set_x : int -> unit; x : int >
+|}];; (* Fail : 'a comp2 is not a subtype *)
(new sorted_list ())#add c2;;
+[%%expect{|
+- : unit = ()
+|}];;
class int_comparable3 (x : int) = object
val mutable x = x
method x = x
method setx y = x <- y
end;;
+[%%expect{|
+class int_comparable3 :
+ int ->
+ object
+ val mutable x : int
+ method cmp : int_comparable -> int
+ method setx : int -> unit
+ method x : int
+ end
+|}];;
let c3 = new int_comparable3 15;;
+[%%expect{|
+val c3 : int_comparable3 = <obj>
+|}];;
l#add (c3 :> int_comparable);;
-(new sorted_list ())#add c3;; (* Error; strange message with -principal *)
+[%%expect{|
+- : unit = ()
+|}];;
+(new sorted_list ())#add c3;;
+[%%expect{|
+Line _, characters 25-27:
+ (new sorted_list ())#add c3;;
+ ^^
+Error: This expression has type
+ int_comparable3 =
+ < cmp : int_comparable -> int; setx : int -> unit; x : int >
+ but an expression was expected of type
+ #comparable as 'a = < cmp : 'a -> int; .. >
+ Type int_comparable = < cmp : int_comparable -> int; x : int >
+ is not compatible with type
+ int_comparable3 =
+ < cmp : int_comparable -> int; setx : int -> unit; x : int >
+ The first object type has no method setx
+|}, Principal{|
+Line _, characters 25-27:
+ (new sorted_list ())#add c3;;
+ ^^
+Error: This expression has type
+ int_comparable3 =
+ < cmp : int_comparable -> int; setx : int -> unit; x : int >
+ but an expression was expected of type
+ #comparable as 'a = < cmp : 'a -> int; .. >
+ Type int_comparable = < cmp : int_comparable -> int; x : int >
+ is not compatible with type 'a = < cmp : 'a -> int; .. >
+ The first object type has no method setx
+|}];; (* Error; strange message with -principal *)
let sort (l : #comparable list) = List.sort (fun x -> x#cmp) l;;
+[%%expect{|
+val sort : (#comparable as 'a) list -> 'a list = <fun>
+|}];;
let pr l =
- List.map (fun c -> print_int c#x; print_string " ") l;
- print_newline ();;
+ List.map (fun c -> Format.print_int c#x; Format.print_string " ") l;
+ Format.print_newline ();;
+[%%expect{|
+Line _, characters 2-69:
+ List.map (fun c -> Format.print_int c#x; Format.print_string " ") l;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 10: this expression should have type unit.
+val pr : < x : int; .. > list -> unit = <fun>
+|}];;
let l = [new int_comparable 5; (new int_comparable3 2 :> int_comparable);
new int_comparable 4];;
+[%%expect{|
+val l : int_comparable list = [<obj>; <obj>; <obj>]
+|}];;
pr l;;
+[%%expect{|
+7(7, red)(3::10::[])(4::11::[])((3, red)::(10, red)::[])5 2 4
+- : unit = ()
+|}];;
pr (sort l);;
+[%%expect{|
+2 4 5
+- : unit = ()
+|}];;
let l = [new int_comparable2 2; new int_comparable2 0];;
+[%%expect{|
+val l : int_comparable2 list = [<obj>; <obj>]
+|}];;
pr l;;
+[%%expect{|
+2 0
+- : unit = ()
+|}];;
pr (sort l);;
+[%%expect{|
+0 2
+- : unit = ()
+|}];;
let min (x : #comparable) y =
if x#cmp y <= 0 then x else y;;
+[%%expect{|
+val min : (#comparable as 'a) -> 'a -> 'a = <fun>
+|}];;
(min (new int_comparable 7) (new int_comparable 11))#x;;
+[%%expect{|
+- : int = 7
+|}];;
(min (new int_comparable2 5) (new int_comparable2 3))#x;;
+[%%expect{|
+- : int = 3
+|}];;
(*******************************************************************)
| Some l' ->
l'#append l
end;;
+[%%expect{|
+class ['a] link :
+ 'a ->
+ object ('b)
+ val mutable next : 'b option
+ val mutable x : 'a
+ method append : 'b option -> unit
+ method next : 'b option
+ method set_next : 'b option -> unit
+ method set_x : 'a -> unit
+ method x : 'a
+ end
+|}];;
class ['a] double_link x = object (self)
inherit ['a] link x
match l with Some l -> l#set_prev (Some self) | None -> ()
method set_prev l = prev <- l
end;;
+[%%expect{|
+class ['a] double_link :
+ 'a ->
+ object ('b)
+ val mutable next : 'b option
+ val mutable prev : 'b option
+ val mutable x : 'a
+ method append : 'b option -> unit
+ method next : 'b option
+ method prev : 'b option
+ method set_next : 'b option -> unit
+ method set_prev : 'b option -> unit
+ method set_x : 'a -> unit
+ method x : 'a
+ end
+|}];;
let rec fold_right f (l : 'a #link option) accu =
match l with
None -> accu
| Some l ->
f l#x (fold_right f l#next accu);;
+[%%expect{|
+val fold_right : ('a -> 'b -> 'b) -> 'a #link option -> 'b -> 'b = <fun>
+|}];;
(*******************************************************************)
self
method equals = equals self
end;;
+[%%expect{|
+class calculator :
+ unit ->
+ object ('a)
+ val mutable acc : float
+ val mutable arg : float
+ val mutable equals : 'a -> float
+ method acc : float
+ method add : 'a
+ method arg : float
+ method enter : float -> 'a
+ method equals : float
+ method sub : 'a
+ end
+|}];;
((new calculator ())#enter 5.)#equals;;
+[%%expect{|
+- : float = 5.
+|}];;
(((new calculator ())#enter 5.)#sub#enter 3.5)#equals;;
+[%%expect{|
+- : float = 1.5
+|}];;
((new calculator ())#enter 5.)#add#add#equals;;
+[%%expect{|
+- : float = 15.
+|}];;
class calculator () = object (self)
val mutable arg = 0.
method sub = {< acc = equals self; equals = function s -> s#acc -. s#arg >}
method equals = equals self
end;;
+[%%expect{|
+class calculator :
+ unit ->
+ object ('a)
+ val mutable acc : float
+ val mutable arg : float
+ val mutable equals : 'a -> float
+ method acc : float
+ method add : 'a
+ method arg : float
+ method enter : float -> 'a
+ method equals : float
+ method sub : 'a
+ end
+|}];;
((new calculator ())#enter 5.)#equals;;
+[%%expect{|
+- : float = 5.
+|}];;
(((new calculator ())#enter 5.)#sub#enter 3.5)#equals;;
+[%%expect{|
+- : float = 1.5
+|}];;
((new calculator ())#enter 5.)#add#add#equals;;
+[%%expect{|
+- : float = 15.
+|}];;
class calculator arg acc = object (self)
val arg = arg
method enter n = new calculator_sub n acc
method equals = acc -. arg
end;;
+[%%expect{|
+class calculator :
+ float ->
+ float ->
+ object
+ val acc : float
+ val arg : float
+ method add : calculator
+ method enter : float -> calculator
+ method equals : float
+ method sub : calculator
+ end
+and calculator_add :
+ float ->
+ float ->
+ object
+ val acc : float
+ val arg : float
+ method add : calculator
+ method enter : float -> calculator
+ method equals : float
+ method sub : calculator
+ end
+and calculator_sub :
+ float ->
+ float ->
+ object
+ val acc : float
+ val arg : float
+ method add : calculator
+ method enter : float -> calculator
+ method equals : float
+ method sub : calculator
+ end
+|}];;
let calculator = new calculator 0. 0.;;
+[%%expect{|
+val calculator : calculator = <obj>
+|}];;
(calculator#enter 5.)#equals;;
+[%%expect{|
+- : float = 5.
+|}];;
((calculator#enter 5.)#sub#enter 3.5)#equals;;
+[%%expect{|
+- : float = 1.5
+|}];;
(calculator#enter 5.)#add#add#equals;;
+[%%expect{|
+- : float = 15.
+|}];;
+++ /dev/null
-
-# class point :
- int ->
- object val mutable x : int method get_x : int method move : int -> unit end
-# val p : point = <obj>
-# - : int = 7
-# - : unit = ()
-# - : int = 10
-# val q : < get_x : int; move : int -> unit > = <obj>
-# - : int * int = (10, 17)
-# class color_point :
- int ->
- string ->
- object
- val c : string
- val mutable x : int
- method color : string
- method get_x : int
- method move : int -> unit
- end
-# val p' : color_point = <obj>
-# - : int * string = (5, "red")
-# val l : point list = [<obj>; <obj>]
-# val get_x : < get_x : 'a; .. > -> 'a = <fun>
-# val set_x : < set_x : 'a; .. > -> 'a = <fun>
-# - : int list = [10; 5]
-# Characters 1-96:
- class ref x_init = object
- val mutable x = x_init
- method get = x
- method set y = x <- y
- end..
-Error: Some type variables are unbound in this type:
- class ref :
- 'a ->
- object
- val mutable x : 'a
- method get : 'a
- method set : 'a -> unit
- end
- The method get has type 'a where 'a is unbound
-# class ref :
- int ->
- object val mutable x : int method get : int method set : int -> unit end
-# class ['a] ref :
- 'a -> object val mutable x : 'a method get : 'a method set : 'a -> unit end
-# - : int = 2
-# class ['a] circle :
- 'a ->
- object
- constraint 'a = < move : int -> unit; .. >
- val mutable center : 'a
- method center : 'a
- method move : int -> unit
- method set_center : 'a -> unit
- end
-# class ['a] circle :
- 'a ->
- object
- constraint 'a = #point
- val mutable center : 'a
- method center : 'a
- method move : int -> unit
- method set_center : 'a -> unit
- end
-# val c : point circle = <obj>
-val c' : < color : string; get_x : int; move : int -> unit > circle = <obj>
-# class ['a] color_circle :
- 'a ->
- object
- constraint 'a = #color_point
- val mutable center : 'a
- method center : 'a
- method color : string
- method move : int -> unit
- method set_center : 'a -> unit
- end
-# Characters 28-29:
- let c'' = new color_circle p;;
- ^
-Error: This expression has type point but an expression was expected of type
- #color_point
- The first object type has no method color
-# val c'' : color_point color_circle = <obj>
-# - : color_point circle = <obj>
-# Characters 0-21:
- (c'' :> point circle);; (* Fail *)
- ^^^^^^^^^^^^^^^^^^^^^
-Error: Type
- color_point color_circle =
- < center : color_point; color : string; move : int -> unit;
- set_center : color_point -> unit >
- is not a subtype of
- point circle =
- < center : point; move : int -> unit; set_center : point -> unit >
- Type point is not a subtype of color_point
-# Characters 9-55:
- fun x -> (x : color_point color_circle :> point circle);;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type
- color_point color_circle =
- < center : color_point; color : string; move : int -> unit;
- set_center : color_point -> unit >
- is not a subtype of
- point circle =
- < center : point; move : int -> unit; set_center : point -> unit >
- Type point is not a subtype of color_point
-# class printable_point :
- int ->
- object
- val mutable x : int
- method get_x : int
- method move : int -> unit
- method print : unit
- end
-# val p : printable_point = <obj>
-# 7- : unit = ()
-# Characters 85-102:
- inherit printable_point y as super
- ^^^^^^^^^^^^^^^^^
-Warning 13: the following instance variables are overridden by the class printable_point :
- x
-The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
-class printable_color_point :
- int ->
- string ->
- object
- val c : string
- val mutable x : int
- method color : string
- method get_x : int
- method move : int -> unit
- method print : unit
- end
-# val p' : printable_color_point = <obj>
-# (7, red)- : unit = ()
-# class functional_point :
- int ->
- object ('a) val x : int method get_x : int method move : int -> 'a end
-# val p : functional_point = <obj>
-# - : int = 7
-# - : int = 10
-# - : int = 7
-# - : #functional_point -> functional_point = <fun>
-# class virtual ['a] lst :
- unit ->
- object
- method virtual hd : 'a
- method iter : ('a -> unit) -> unit
- method map : ('a -> 'a) -> 'a lst
- method virtual null : bool
- method print : ('a -> unit) -> unit
- method virtual tl : 'a lst
- end
-and ['a] nil :
- unit ->
- object
- method hd : 'a
- method iter : ('a -> unit) -> unit
- method map : ('a -> 'a) -> 'a lst
- method null : bool
- method print : ('a -> unit) -> unit
- method tl : 'a lst
- end
-and ['a] cons :
- 'a ->
- 'a lst ->
- object
- val h : 'a
- val t : 'a lst
- method hd : 'a
- method iter : ('a -> unit) -> unit
- method map : ('a -> 'a) -> 'a lst
- method null : bool
- method print : ('a -> unit) -> unit
- method tl : 'a lst
- end
-# val l1 : int lst = <obj>
-# (3::10::[])- : unit = ()
-# val l2 : int lst = <obj>
-# (4::11::[])- : unit = ()
-# val map_list : ('a -> 'b) -> 'a lst -> 'b lst = <fun>
-# val p1 : printable_color_point lst = <obj>
-# ((3, red)::(10, red)::[])- : unit = ()
-# class virtual comparable :
- unit -> object ('a) method virtual cmp : 'a -> int end
-# class int_comparable :
- int -> object ('a) val x : int method cmp : 'a -> int method x : int end
-# class int_comparable2 :
- int ->
- object ('a)
- val x : int
- val mutable x' : int
- method cmp : 'a -> int
- method set_x : int -> unit
- method x : int
- end
-# class ['a] sorted_list :
- unit ->
- object
- constraint 'a = #comparable
- val mutable l : 'a list
- method add : 'a -> unit
- method hd : 'a
- end
-# val l : _#comparable sorted_list = <obj>
-# val c : int_comparable = <obj>
-# - : unit = ()
-# val c2 : int_comparable2 = <obj>
-# Characters 6-28:
- l#add (c2 :> int_comparable);; (* Fail : 'a comp2 is not a subtype *)
- ^^^^^^^^^^^^^^^^^^^^^^
-Error: Type
- int_comparable2 =
- < cmp : int_comparable2 -> int; set_x : int -> unit; x : int >
- is not a subtype of
- int_comparable = < cmp : int_comparable -> int; x : int >
- Type int_comparable = < cmp : int_comparable -> int; x : int >
- is not a subtype of
- int_comparable2 =
- < cmp : int_comparable2 -> int; set_x : int -> unit; x : int >
-# - : unit = ()
-# class int_comparable3 :
- int ->
- object
- val mutable x : int
- method cmp : int_comparable -> int
- method setx : int -> unit
- method x : int
- end
-# val c3 : int_comparable3 = <obj>
-# - : unit = ()
-# Characters 25-27:
- (new sorted_list ())#add c3;; (* Error; strange message with -principal *)
- ^^
-Error: This expression has type
- int_comparable3 =
- < cmp : int_comparable -> int; setx : int -> unit; x : int >
- but an expression was expected of type
- #comparable as 'a = < cmp : 'a -> int; .. >
- Type int_comparable = < cmp : int_comparable -> int; x : int >
- is not compatible with type 'a = < cmp : 'a -> int; .. >
- The first object type has no method setx
-# val sort : (#comparable as 'a) list -> 'a list = <fun>
-# Characters 13-66:
- List.map (fun c -> print_int c#x; print_string " ") l;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 10: this expression should have type unit.
-val pr : < x : int; .. > list -> unit = <fun>
-# val l : int_comparable list = [<obj>; <obj>; <obj>]
-# 5 2 4
-- : unit = ()
-# 2 4 5
-- : unit = ()
-# val l : int_comparable2 list = [<obj>; <obj>]
-# 2 0
-- : unit = ()
-# 0 2
-- : unit = ()
-# val min : (#comparable as 'a) -> 'a -> 'a = <fun>
-# - : int = 7
-# - : int = 3
-# class ['a] link :
- 'a ->
- object ('b)
- val mutable next : 'b option
- val mutable x : 'a
- method append : 'b option -> unit
- method next : 'b option
- method set_next : 'b option -> unit
- method set_x : 'a -> unit
- method x : 'a
- end
-# class ['a] double_link :
- 'a ->
- object ('b)
- val mutable next : 'b option
- val mutable prev : 'b option
- val mutable x : 'a
- method append : 'b option -> unit
- method next : 'b option
- method prev : 'b option
- method set_next : 'b option -> unit
- method set_prev : 'b option -> unit
- method set_x : 'a -> unit
- method x : 'a
- end
-# val fold_right : ('a -> 'b -> 'b) -> 'a #link option -> 'b -> 'b = <fun>
-# class calculator :
- unit ->
- object ('a)
- val mutable acc : float
- val mutable arg : float
- val mutable equals : 'a -> float
- method acc : float
- method add : 'a
- method arg : float
- method enter : float -> 'a
- method equals : float
- method sub : 'a
- end
-# - : float = 5.
-# - : float = 1.5
-# - : float = 15.
-# class calculator :
- unit ->
- object ('a)
- val mutable acc : float
- val mutable arg : float
- val mutable equals : 'a -> float
- method acc : float
- method add : 'a
- method arg : float
- method enter : float -> 'a
- method equals : float
- method sub : 'a
- end
-# - : float = 5.
-# - : float = 1.5
-# - : float = 15.
-# class calculator :
- float ->
- float ->
- object
- val acc : float
- val arg : float
- method add : calculator
- method enter : float -> calculator
- method equals : float
- method sub : calculator
- end
-and calculator_add :
- float ->
- float ->
- object
- val acc : float
- val arg : float
- method add : calculator
- method enter : float -> calculator
- method equals : float
- method sub : calculator
- end
-and calculator_sub :
- float ->
- float ->
- object
- val acc : float
- val arg : float
- method add : calculator
- method enter : float -> calculator
- method equals : float
- method sub : calculator
- end
-# val calculator : calculator = <obj>
-# - : float = 5.
-# - : float = 1.5
-# - : float = 15.
-#
+++ /dev/null
-
-# class point :
- int ->
- object val mutable x : int method get_x : int method move : int -> unit end
-# val p : point = <obj>
-# - : int = 7
-# - : unit = ()
-# - : int = 10
-# val q : point = <obj>
-# - : int * int = (10, 17)
-# class color_point :
- int ->
- string ->
- object
- val c : string
- val mutable x : int
- method color : string
- method get_x : int
- method move : int -> unit
- end
-# val p' : color_point = <obj>
-# - : int * string = (5, "red")
-# val l : point list = [<obj>; <obj>]
-# val get_x : < get_x : 'a; .. > -> 'a = <fun>
-# val set_x : < set_x : 'a; .. > -> 'a = <fun>
-# - : int list = [10; 5]
-# Characters 1-96:
- class ref x_init = object
- val mutable x = x_init
- method get = x
- method set y = x <- y
- end..
-Error: Some type variables are unbound in this type:
- class ref :
- 'a ->
- object
- val mutable x : 'a
- method get : 'a
- method set : 'a -> unit
- end
- The method get has type 'a where 'a is unbound
-# class ref :
- int ->
- object val mutable x : int method get : int method set : int -> unit end
-# class ['a] ref :
- 'a -> object val mutable x : 'a method get : 'a method set : 'a -> unit end
-# - : int = 2
-# class ['a] circle :
- 'a ->
- object
- constraint 'a = < move : int -> unit; .. >
- val mutable center : 'a
- method center : 'a
- method move : int -> unit
- method set_center : 'a -> unit
- end
-# class ['a] circle :
- 'a ->
- object
- constraint 'a = #point
- val mutable center : 'a
- method center : 'a
- method move : int -> unit
- method set_center : 'a -> unit
- end
-# val c : point circle = <obj>
-val c' : color_point circle = <obj>
-# class ['a] color_circle :
- 'a ->
- object
- constraint 'a = #color_point
- val mutable center : 'a
- method center : 'a
- method color : string
- method move : int -> unit
- method set_center : 'a -> unit
- end
-# Characters 28-29:
- let c'' = new color_circle p;;
- ^
-Error: This expression has type point but an expression was expected of type
- #color_point
- The first object type has no method color
-# val c'' : color_point color_circle = <obj>
-# - : color_point circle = <obj>
-# Characters 0-21:
- (c'' :> point circle);; (* Fail *)
- ^^^^^^^^^^^^^^^^^^^^^
-Error: Type
- color_point color_circle =
- < center : color_point; color : string; move : int -> unit;
- set_center : color_point -> unit >
- is not a subtype of
- point circle =
- < center : point; move : int -> unit; set_center : point -> unit >
- Type point is not a subtype of color_point
-# Characters 9-55:
- fun x -> (x : color_point color_circle :> point circle);;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type
- color_point color_circle =
- < center : color_point; color : string; move : int -> unit;
- set_center : color_point -> unit >
- is not a subtype of
- point circle =
- < center : point; move : int -> unit; set_center : point -> unit >
- Type point is not a subtype of color_point
-# class printable_point :
- int ->
- object
- val mutable x : int
- method get_x : int
- method move : int -> unit
- method print : unit
- end
-# val p : printable_point = <obj>
-# 7- : unit = ()
-# Characters 85-102:
- inherit printable_point y as super
- ^^^^^^^^^^^^^^^^^
-Warning 13: the following instance variables are overridden by the class printable_point :
- x
-The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
-class printable_color_point :
- int ->
- string ->
- object
- val c : string
- val mutable x : int
- method color : string
- method get_x : int
- method move : int -> unit
- method print : unit
- end
-# val p' : printable_color_point = <obj>
-# (7, red)- : unit = ()
-# class functional_point :
- int ->
- object ('a) val x : int method get_x : int method move : int -> 'a end
-# val p : functional_point = <obj>
-# - : int = 7
-# - : int = 10
-# - : int = 7
-# - : #functional_point -> functional_point = <fun>
-# class virtual ['a] lst :
- unit ->
- object
- method virtual hd : 'a
- method iter : ('a -> unit) -> unit
- method map : ('a -> 'a) -> 'a lst
- method virtual null : bool
- method print : ('a -> unit) -> unit
- method virtual tl : 'a lst
- end
-and ['a] nil :
- unit ->
- object
- method hd : 'a
- method iter : ('a -> unit) -> unit
- method map : ('a -> 'a) -> 'a lst
- method null : bool
- method print : ('a -> unit) -> unit
- method tl : 'a lst
- end
-and ['a] cons :
- 'a ->
- 'a lst ->
- object
- val h : 'a
- val t : 'a lst
- method hd : 'a
- method iter : ('a -> unit) -> unit
- method map : ('a -> 'a) -> 'a lst
- method null : bool
- method print : ('a -> unit) -> unit
- method tl : 'a lst
- end
-# val l1 : int lst = <obj>
-# (3::10::[])- : unit = ()
-# val l2 : int lst = <obj>
-# (4::11::[])- : unit = ()
-# val map_list : ('a -> 'b) -> 'a lst -> 'b lst = <fun>
-# val p1 : printable_color_point lst = <obj>
-# ((3, red)::(10, red)::[])- : unit = ()
-# class virtual comparable :
- unit -> object ('a) method virtual cmp : 'a -> int end
-# class int_comparable :
- int -> object ('a) val x : int method cmp : 'a -> int method x : int end
-# class int_comparable2 :
- int ->
- object ('a)
- val x : int
- val mutable x' : int
- method cmp : 'a -> int
- method set_x : int -> unit
- method x : int
- end
-# class ['a] sorted_list :
- unit ->
- object
- constraint 'a = #comparable
- val mutable l : 'a list
- method add : 'a -> unit
- method hd : 'a
- end
-# val l : _#comparable sorted_list = <obj>
-# val c : int_comparable = <obj>
-# - : unit = ()
-# val c2 : int_comparable2 = <obj>
-# Characters 6-28:
- l#add (c2 :> int_comparable);; (* Fail : 'a comp2 is not a subtype *)
- ^^^^^^^^^^^^^^^^^^^^^^
-Error: Type
- int_comparable2 =
- < cmp : int_comparable2 -> int; set_x : int -> unit; x : int >
- is not a subtype of
- int_comparable = < cmp : int_comparable -> int; x : int >
- Type int_comparable = < cmp : int_comparable -> int; x : int >
- is not a subtype of
- int_comparable2 =
- < cmp : int_comparable2 -> int; set_x : int -> unit; x : int >
-# - : unit = ()
-# class int_comparable3 :
- int ->
- object
- val mutable x : int
- method cmp : int_comparable -> int
- method setx : int -> unit
- method x : int
- end
-# val c3 : int_comparable3 = <obj>
-# - : unit = ()
-# Characters 25-27:
- (new sorted_list ())#add c3;; (* Error; strange message with -principal *)
- ^^
-Error: This expression has type
- int_comparable3 =
- < cmp : int_comparable -> int; setx : int -> unit; x : int >
- but an expression was expected of type
- #comparable as 'a = < cmp : 'a -> int; .. >
- Type int_comparable = < cmp : int_comparable -> int; x : int >
- is not compatible with type
- int_comparable3 =
- < cmp : int_comparable -> int; setx : int -> unit; x : int >
- The first object type has no method setx
-# val sort : (#comparable as 'a) list -> 'a list = <fun>
-# Characters 13-66:
- List.map (fun c -> print_int c#x; print_string " ") l;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 10: this expression should have type unit.
-val pr : < x : int; .. > list -> unit = <fun>
-# val l : int_comparable list = [<obj>; <obj>; <obj>]
-# 5 2 4
-- : unit = ()
-# 2 4 5
-- : unit = ()
-# val l : int_comparable2 list = [<obj>; <obj>]
-# 2 0
-- : unit = ()
-# 0 2
-- : unit = ()
-# val min : (#comparable as 'a) -> 'a -> 'a = <fun>
-# - : int = 7
-# - : int = 3
-# class ['a] link :
- 'a ->
- object ('b)
- val mutable next : 'b option
- val mutable x : 'a
- method append : 'b option -> unit
- method next : 'b option
- method set_next : 'b option -> unit
- method set_x : 'a -> unit
- method x : 'a
- end
-# class ['a] double_link :
- 'a ->
- object ('b)
- val mutable next : 'b option
- val mutable prev : 'b option
- val mutable x : 'a
- method append : 'b option -> unit
- method next : 'b option
- method prev : 'b option
- method set_next : 'b option -> unit
- method set_prev : 'b option -> unit
- method set_x : 'a -> unit
- method x : 'a
- end
-# val fold_right : ('a -> 'b -> 'b) -> 'a #link option -> 'b -> 'b = <fun>
-# class calculator :
- unit ->
- object ('a)
- val mutable acc : float
- val mutable arg : float
- val mutable equals : 'a -> float
- method acc : float
- method add : 'a
- method arg : float
- method enter : float -> 'a
- method equals : float
- method sub : 'a
- end
-# - : float = 5.
-# - : float = 1.5
-# - : float = 15.
-# class calculator :
- unit ->
- object ('a)
- val mutable acc : float
- val mutable arg : float
- val mutable equals : 'a -> float
- method acc : float
- method add : 'a
- method arg : float
- method enter : float -> 'a
- method equals : float
- method sub : 'a
- end
-# - : float = 5.
-# - : float = 1.5
-# - : float = 15.
-# class calculator :
- float ->
- float ->
- object
- val acc : float
- val arg : float
- method add : calculator
- method enter : float -> calculator
- method equals : float
- method sub : calculator
- end
-and calculator_add :
- float ->
- float ->
- object
- val acc : float
- val arg : float
- method add : calculator
- method enter : float -> calculator
- method equals : float
- method sub : calculator
- end
-and calculator_sub :
- float ->
- float ->
- object
- val acc : float
- val arg : float
- method add : calculator
- method enter : float -> calculator
- method equals : float
- method sub : calculator
- end
-# val calculator : calculator = <obj>
-# - : float = 5.
-# - : float = 1.5
-# - : float = 15.
-#
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * expect
+*)
+
(* Subtyping is "syntactic" *)
fun (x : < x : int >) y z -> (y :> 'a), (x :> 'a), (z :> 'a);;
+[%%expect{|
+- : < x : int > ->
+ < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int >
+= <fun>
+|}];;
(* - : (< x : int > as 'a) -> 'a -> 'a * 'a = <fun> *)
(* Quirks of class typing. *)
end and ['a] d () = object
inherit ['a] c ()
end;;
+[%%expect{|
+class ['a] c : unit -> object constraint 'a = int method f : int c end
+and ['a] d : unit -> object constraint 'a = int method f : int c end
+|}];;
(* class ['a] c : unit -> object constraint 'a = int method f : 'a c end *)
(* and ['a] d : unit -> object constraint 'a = int method f : 'a c end *)
end and d () = object
inherit ['a] c ()
end;;
+[%%expect{|
+Line _, characters 4-45:
+ ....and d () = object
+ inherit ['a] c ()
+ end..
+Error: Some type variables are unbound in this type:
+ class d : unit -> object method f : 'a -> unit end
+ The method f has type 'a -> unit where 'a is unbound
+|}];;
(* Create instance #c *)
class virtual c () = object
constraint 'a = #c
method f (x : #c) = (x#x : int)
end;;
+[%%expect{|
+class virtual c : unit -> object end
+and ['a] d :
+ unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end
+|}];;
(* class virtual c : unit -> object end *)
(* and ['a] d : *)
(* unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end *)
end and ['a] d () = object
constraint 'a = 'b #c
end;;
+[%%expect{|
+class ['a] c : unit -> object constraint 'a = int end
+and ['a] d : unit -> object constraint 'a = int #c end
+|}];;
(* class ['a] c : unit -> object constraint 'a = int end
and ['a] d : unit -> object constraint 'a = int #c end *)
constraint 'a = 'b
method f = self
end;;
+[%%expect{|
+class ['a] c :
+ 'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end
+|}];;
new c;;
+[%%expect{|
+- : ('a c as 'a) -> 'a = <fun>
+|}];;
(* class ['a] c :
'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end *)
(* - : ('a c as 'a) -> 'a = <fun> *)
class x () = object
method virtual f : int
end;;
+[%%expect{|
+Line _, characters 0-48:
+ class x () = object
+ method virtual f : int
+ end..
+Error: This class should be virtual. The following methods are undefined : f
+|}];;
(* The class x should be virtual: its methods f is undefined *)
(* Supplementary method g *)
inherit c x
method g = true
end;;
+[%%expect{|
+Line _, characters 49-57:
+ class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end
+ ^^^^^^^^
+Error: This pattern cannot match self: it only matches values of type
+ < f : int >
+|}];;
(* Constraint not respected *)
class ['a] c () = object
constraint 'a = int
method f x = (x : bool c)
end;;
+[%%expect{|
+Line _, characters 0-78:
+ class ['a] c () = object
+ constraint 'a = int
+ method f x = (x : bool c)
+ end..
+Error: The abbreviation c is used with parameters bool c
+ which are incompatible with constraints int c
+|}];;
(* Different constraints *)
class ['a, 'b] c () = object
constraint 'b = 'a * <x : 'b> * 'c * 'd
method f (x : 'a) (y : 'b) = ()
end;;
+[%%expect{|
+class ['a, 'b] c :
+ unit ->
+ object
+ constraint 'a = int -> 'c
+ constraint 'b = 'a * < x : 'b > * 'c * 'd
+ method f : 'a -> 'b -> unit
+ end
+|}];;
class ['a, 'b] d () = object
inherit ['a, 'b] c ()
end;;
+[%%expect{|
+class ['a, 'b] d :
+ unit ->
+ object
+ constraint 'a = int -> 'c
+ constraint 'b = 'a * < x : 'b > * 'c * 'd
+ method f : 'a -> 'b -> unit
+ end
+|}];;
(* Non-generic constraint *)
let x = ref [];;
+[%%expect{|
+val x : '_weak1 list ref = {contents = []}
+|}];;
class ['a] c () = object
method f = (x : 'a)
end;;
+[%%expect{|
+Line _, characters 0-50:
+ class ['a] c () = object
+ method f = (x : 'a)
+ end..
+Error: The type of this class,
+ class ['a] c :
+ unit -> object constraint 'a = '_weak1 list ref method f : 'a end,
+ contains type variables that cannot be generalized
+|}];;
(* Abbreviations *)
type 'a c = <f : 'a c; g : 'a d>
and 'a d = <f : int c>;;
+[%%expect{|
+Line _, characters 0-32:
+ type 'a c = <f : 'a c; g : 'a d>
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In the definition of d, type int c should be 'a c
+|}];;
type 'a c = <f : 'a c; g : 'a d>
and 'a d = <f : 'a c>;;
+[%%expect{|
+type 'a c = < f : 'a c; g : 'a d >
+and 'a d = < f : 'a c >
+|}];;
type 'a c = <f : 'a c>
and 'a d = <f : int c>;;
+[%%expect{|
+type 'a c = < f : 'a c >
+and 'a d = < f : int c >
+|}];;
type 'a u = < x : 'a>
-and 'a t = 'a t u;; (* fails since 4.04 *)
+and 'a t = 'a t u;;
+[%%expect{|
+Line _, characters 0-17:
+ and 'a t = 'a t u;;
+ ^^^^^^^^^^^^^^^^^
+Error: The definition of t contains a cycle:
+ 'a t u
+|}];; (* fails since 4.04 *)
type 'a u = 'a
and 'a t = 'a t u;;
+[%%expect{|
+Line _, characters 0-17:
+ and 'a t = 'a t u;;
+ ^^^^^^^^^^^^^^^^^
+Error: The type abbreviation t is cyclic
+|}];;
type 'a u = 'a;;
+[%%expect{|
+type 'a u = 'a
+|}];;
type t = t u * t u;;
+[%%expect{|
+Line _, characters 0-18:
+ type t = t u * t u;;
+ ^^^^^^^^^^^^^^^^^^
+Error: The type abbreviation t is cyclic
+|}];;
type t = <x : 'a> as 'a;;
+[%%expect{|
+type t = < x : 'a > as 'a
+|}];;
type 'a u = 'a;;
+[%%expect{|
+type 'a u = 'a
+|}];;
fun (x : t) (y : 'a u) -> x = y;;
+[%%expect{|
+- : t -> t u -> bool = <fun>
+|}];;
fun (x : t) (y : 'a u) -> y = x;;
+[%%expect{|
+- : t -> t u -> bool = <fun>
+|}];;
(* - : t -> t u -> bool = <fun> *)
(* Modules *)
method g = y
end
end;;
+[%%expect{|
+module M :
+ sig
+ class ['a, 'b] c :
+ int ->
+ 'b ->
+ object
+ constraint 'a = int -> bool
+ val x : float list
+ val y : 'b
+ method f : 'a -> unit
+ method g : 'b
+ end
+ end
+|}];;
module M' = (M :
sig
class virtual ['a, 'b] c : int -> 'b -> object
method g : 'b
end
end);;
+[%%expect{|
+module M' :
+ sig
+ class virtual ['a, 'b] c :
+ int ->
+ 'b ->
+ object
+ constraint 'a = int -> bool
+ val x : float list
+ val y : 'b
+ method f : 'a -> unit
+ method g : 'b
+ end
+ end
+|}];;
class ['a, 'b] d () y = object inherit ['a, 'b] M.c 7 y end;;
+[%%expect{|
+class ['a, 'b] d :
+ unit ->
+ 'b ->
+ object
+ constraint 'a = int -> bool
+ val x : float list
+ val y : 'b
+ method f : 'a -> unit
+ method g : 'b
+ end
+|}];;
class ['a, 'b] e () y = object inherit ['a, 'b] M'.c 1 y end;;
+[%%expect{|
+class ['a, 'b] e :
+ unit ->
+ 'b ->
+ object
+ constraint 'a = int -> bool
+ val x : float list
+ val y : 'b
+ method f : 'a -> unit
+ method g : 'b
+ end
+|}];;
(new M.c 3 "a")#g;;
+[%%expect{|
+- : string = "a"
+|}];;
(new d () 10)#g;;
+[%%expect{|
+- : int = 10
+|}];;
(new e () 7.1)#g;;
+[%%expect{|
+- : float = 7.1
+|}];;
open M;;
+[%%expect{|
+|}];;
(new c 5 true)#g;;
+[%%expect{|
+- : bool = true
+|}];;
(* #cl when cl is closed *)
module M = struct class ['a] c () = object method f (x : 'a) = () end end;;
+[%%expect{|
+module M : sig class ['a] c : unit -> object method f : 'a -> unit end end
+|}];;
module M' =
(M : sig class ['a] c : unit -> object method f : 'a -> unit end end);;
+[%%expect{|
+module M' : sig class ['a] c : unit -> object method f : 'a -> unit end end
+|}];;
fun x -> (x :> 'a #M.c);;
+[%%expect{|
+- : ('a #M.c as 'b) -> 'b = <fun>
+|}];;
fun x -> (x :> 'a #M'.c);;
+[%%expect{|
+- : ('a #M'.c as 'b) -> 'b = <fun>
+|}];;
class ['a] c (x : 'b #c) = object end;;
+[%%expect{|
+class ['a] c : 'a #c -> object end
+|}];;
class ['a] c (x : 'b #c) = object end;;
+[%%expect{|
+class ['a] c : 'a #c -> object end
+|}];;
(* Computation order *)
class c () = object method f = 1 end and d () = object method f = 2 end;;
+[%%expect{|
+class c : unit -> object method f : int end
+and d : unit -> object method f : int end
+|}];;
class e () = object inherit c () inherit d () end;;
+[%%expect{|
+class e : unit -> object method f : int end
+|}];;
(new e ())#f;;
+[%%expect{|
+- : int = 2
+|}];;
class c () = object val x = - true val y = -. () end;;
+[%%expect{|
+Line _, characters 30-34:
+ class c () = object val x = - true val y = -. () end;;
+ ^^^^
+Error: This expression has type bool but an expression was expected of type
+ int
+|}];;
class c () = object method f = 1 method g = 1 method h = 1 end;;
+[%%expect{|
+class c : unit -> object method f : int method g : int method h : int end
+|}];;
class d () = object method h = 2 method i = 2 method j = 2 end;;
+[%%expect{|
+class d : unit -> object method h : int method i : int method j : int end
+|}];;
class e () = object
method f = 3
inherit c ()
inherit d ()
method j = 3
end;;
+[%%expect{|
+class e :
+ unit ->
+ object
+ method f : int
+ method g : int
+ method h : int
+ method i : int
+ method j : int
+ end
+|}];;
let e = new e ();;
+[%%expect{|
+val e : e = <obj>
+|}];;
e#f, e#g, e#h, e#i, e#j;;
+[%%expect{|
+- : int * int * int * int * int = (1, 3, 2, 2, 3)
+|}];;
class c a = object val x = 1 val y = 1 val z = 1 val a = a end;;
+[%%expect{|
+class c : 'a -> object val a : 'a val x : int val y : int val z : int end
+|}];;
class d b = object val z = 2 val t = 2 val u = 2 val b = b end;;
+[%%expect{|
+class d : 'a -> object val b : 'a val t : int val u : int val z : int end
+|}];;
class e () = object
val x = 3
inherit c 5
method a = a
method b = b
end;;
+[%%expect{|
+Line _, characters 10-13:
+ inherit c 5
+ ^^^
+Warning 13: the following instance variables are overridden by the class c :
+ x
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Line _, characters 6-7:
+ val y = 3
+ ^
+Warning 13: the instance variable y is overridden.
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Line _, characters 10-13:
+ inherit d 7
+ ^^^
+Warning 13: the following instance variables are overridden by the class d :
+ t z
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Line _, characters 6-7:
+ val u = 3
+ ^
+Warning 13: the instance variable u is overridden.
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+class e :
+ unit ->
+ object
+ val a : int
+ val b : int
+ val t : int
+ val u : int
+ val x : int
+ val y : int
+ val z : int
+ method a : int
+ method b : int
+ method t : int
+ method u : int
+ method x : int
+ method y : int
+ method z : int
+ end
+|}];;
let e = new e ();;
+[%%expect{|
+val e : e = <obj>
+|}];;
e#x, e#y, e#z, e#t, e#u, e#a, e#b;;
+[%%expect{|
+- : int * int * int * int * int * int * int = (1, 3, 2, 2, 3, 5, 7)
+|}];;
class c (x : int) (y : int) = object
val x = x
method x = x
method y = y
end;;
+[%%expect{|
+class c :
+ int ->
+ int -> object val x : int val y : int method x : int method y : int end
+|}];;
class d x y = object inherit c x y end;;
+[%%expect{|
+class d :
+ int ->
+ int -> object val x : int val y : int method x : int method y : int end
+|}];;
let c = new c 1 2 in c#x, c#y;;
+[%%expect{|
+- : int * int = (1, 2)
+|}];;
let d = new d 1 2 in d#x, d#y;;
+[%%expect{|
+- : int * int = (1, 2)
+|}];;
(* Parameters which does not appear in the object type *)
class ['a] c (x : 'a) = object end;;
+[%%expect{|
+class ['a] c : 'a -> object end
+|}];;
new c;;
+[%%expect{|
+- : 'a -> 'a c = <fun>
+|}];;
(* Private variables *)
(*
class c : unit -> object val x : int end
class d : unit -> object inherit c val private x : int val x : bool end
end;;
+[%%expect{|
+foo
+|}];;
class c (x : int) =
val private mutable x = x
method get = x
method set y = x <- y
end;;
+[%%expect{|
+foo
+|}];;
let c = new c 5;;
+[%%expect{|
+foo
+|}];;
c#get;;
+[%%expect{|
+foo
+|}];;
c#set 7; c#get;;
+[%%expect{|
+foo
+|}];;
class c () = val x = 1 val y = 1 method c = x end;;
+[%%expect{|
+foo
+|}];;
class d () = inherit c () val private x method d = x end;;
+[%%expect{|
+foo
+|}];;
class e () =
val x = 2 val y = 2 inherit d () method x = x method y = y
end;;
+[%%expect{|
+foo
+|}];;
let e = new e () in e#x, e#y, e#c, e#d;;
+[%%expect{|
+foo
+|}];;
*)
(* Forgotten variables in interfaces *)
method xc = x
end
end;;
+[%%expect{|
+module M : sig class c : unit -> object method xc : int end end
+|}];;
class d () = object
val x = 2
method xd = x
inherit M.c ()
end;;
+[%%expect{|
+class d : unit -> object val x : int method xc : int method xd : int end
+|}];;
let d = new d () in d#xc, d#xd;;
+[%%expect{|
+- : int * int = (1, 2)
+|}];;
class virtual ['a] matrix (sz, init : int * 'a) = object
val m = Array.make_matrix sz sz init
method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a)
end;;
+[%%expect{|
+Line _, characters 0-153:
+ class virtual ['a] matrix (sz, init : int * 'a) = object
+ val m = Array.make_matrix sz sz init
+ method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a)
+ end..
+Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a >
+ but is used with type < m : 'a array array; .. >
+|}];;
class c () = object method m = new c () end;;
+[%%expect{|
+class c : unit -> object method m : c end
+|}];;
(new c ())#m;;
+[%%expect{|
+- : c = <obj>
+|}];;
module M = struct class c () = object method m = new c () end end;;
+[%%expect{|
+module M : sig class c : unit -> object method m : c end end
+|}];;
(new M.c ())#m;;
+[%%expect{|
+- : M.c = <obj>
+|}];;
type uu = A of int | B of (<leq: 'a> as 'a);;
+[%%expect{|
+type uu = A of int | B of (< leq : 'a > as 'a)
+|}];;
class virtual c () = object (_ : 'a) method virtual m : 'a end;;
+[%%expect{|
+class virtual c : unit -> object ('a) method virtual m : 'a end
+|}];;
module S = (struct
let f (x : #c) = x
end : sig
val f : (#c as 'a) -> 'a
end);;
+[%%expect{|
+module S : sig val f : (#c as 'a) -> 'a end
+|}];;
module S = (struct
let f (x : #c) = x
end : sig
val f : #c -> #c
end);;
+[%%expect{|
+Line _, characters 12-43:
+ ............struct
+ let f (x : #c) = x
+ end......
+Error: Signature mismatch:
+ Modules do not match:
+ sig val f : (#c as 'a) -> 'a end
+ is not included in
+ sig val f : #c -> #c end
+ Values do not match:
+ val f : (#c as 'a) -> 'a
+ is not included in
+ val f : #c -> #c
+|}];;
module M = struct type t = int class t () = object end end;;
+[%%expect{|
+Line _, characters 37-38:
+ module M = struct type t = int class t () = object end end;;
+ ^
+Error: Multiple definition of the type name t.
+ Names must be unique in a given structure or signature.
+|}];;
fun x -> (x :> < m : 'a -> 'a > as 'a);;
+[%%expect{|
+- : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = <fun>
+|}];;
fun x -> (x : int -> bool :> 'a -> 'a);;
+[%%expect{|
+Line _, characters 9-38:
+ fun x -> (x : int -> bool :> 'a -> 'a);;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type int -> bool is not a subtype of int -> int
+ Type bool is not a subtype of int
+|}];;
fun x -> (x : int -> bool :> int -> int);;
+[%%expect{|
+Line _, characters 9-40:
+ fun x -> (x : int -> bool :> int -> int);;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type int -> bool is not a subtype of int -> int
+ Type bool is not a subtype of int
+|}];;
fun x -> (x : < > :> < .. >);;
+[%%expect{|
+- : < > -> < > = <fun>
+|}];;
fun x -> (x : < .. > :> < >);;
+[%%expect{|
+- : < .. > -> < > = <fun>
+|}];;
let x = ref [];;
+[%%expect{|
+val x : '_weak2 list ref = {contents = []}
+|}];;
module F(X : sig end) =
struct type t = int let _ = (x : < m : t> list ref) end;;
+[%%expect{|
+module F : functor (X : sig end) -> sig type t = int end
+|}];;
x;;
+[%%expect{|
+- : < m : int > list ref = {contents = []}
+|}];;
type 'a t;;
+[%%expect{|
+type 'a t
+|}];;
fun (x : 'a t as 'a) -> ();;
+[%%expect{|
+Line _, characters 9-19:
+ fun (x : 'a t as 'a) -> ();;
+ ^^^^^^^^^^
+Error: This alias is bound to type 'a t but is used as an instance of type 'a
+ The type variable 'a occurs inside 'a t
+|}];;
fun (x : 'a t) -> (x : 'a); ();;
+[%%expect{|
+Line _, characters 19-20:
+ fun (x : 'a t) -> (x : 'a); ();;
+ ^
+Error: This expression has type 'a t but an expression was expected of type
+ 'a
+ The type variable 'a occurs inside 'a t
+|}];;
type 'a t = < x : 'a >;;
+[%%expect{|
+type 'a t = < x : 'a >
+|}];;
fun (x : 'a t as 'a) -> ();;
+[%%expect{|
+- : ('a t as 'a) -> unit = <fun>
+|}];;
fun (x : 'a t) -> (x : 'a); ();;
+[%%expect{|
+Line _, characters 18-26:
+ fun (x : 'a t) -> (x : 'a); ();;
+ ^^^^^^^^
+Warning 10: this expression should have type unit.
+- : ('a t as 'a) t -> unit = <fun>
+|}];;
class ['a] c () = object
constraint 'a = < .. > -> unit
method m = (fun x -> () : 'a)
end;;
+[%%expect{|
+class ['a] c :
+ unit ->
+ object constraint 'a = (< .. > as 'b) -> unit method m : 'b -> unit end
+|}];;
class ['a] c () = object
constraint 'a = unit -> < .. >
method m (f : 'a) = f ()
end;;
+[%%expect{|
+class ['a] c :
+ unit ->
+ object constraint 'a = unit -> (< .. > as 'b) method m : 'a -> 'b end
+|}];;
class c () = object (self)
method private m = 1
method n = self#m
end;;
+[%%expect{|
+class c : unit -> object method private m : int method n : int end
+|}];;
class d () = object (self)
inherit c ()
method o = self#m
end;;
+[%%expect{|
+class d :
+ unit -> object method private m : int method n : int method o : int end
+|}];;
let x = new d () in x#n, x#o;;
+[%%expect{|
+- : int * int = (1, 1)
+|}];;
class c () = object method virtual m : int method private m = 1 end;;
+[%%expect{|
+class c : unit -> object method m : int end
+|}];;
(* Marshaling (cf. PR#5436) *)
let r = ref 0;;
+[%%expect{|
+val r : int ref = {contents = 0}
+|}];;
let id o = Oo.id o - !r;;
+[%%expect{|
+val id : < .. > -> int = <fun>
+|}];;
r := Oo.id (object end);;
+[%%expect{|
+- : unit = ()
+|}];;
id (object end);;
+[%%expect{|
+- : int = 1
+|}];;
id (object end);;
+[%%expect{|
+- : int = 2
+|}];;
let o = object end in
let s = Marshal.to_string o [] in
let o' : < > = Marshal.from_string s 0 in
let o'' : < > = Marshal.from_string s 0 in
(id o, id o', id o'');;
+[%%expect{|
+- : int * int * int = (3, 4, 5)
+|}];;
let o = object val x = 33 method m = x end in
let s = Marshal.to_string o [Marshal.Closures] in
let o' : <m:int> = Marshal.from_string s 0 in
let o'' : <m:int> = Marshal.from_string s 0 in
(id o, id o', id o'', o#m, o'#m);;
+[%%expect{|
+- : int * int * int * int * int = (6, 7, 8, 33, 33)
+|}];;
let o = object val x = 33 val y = 44 method m = x end in
let s = Marshal.to_string (o,o) [Marshal.Closures] in
let (o1, o2) : (<m:int> * <m:int>) = Marshal.from_string s 0 in
let (o3, o4) : (<m:int> * <m:int>) = Marshal.from_string s 0 in
(id o, id o1, id o2, id o3, id o4, o#m, o1#m);;
+[%%expect{|
+- : int * int * int * int * int * int * int = (9, 10, 10, 11, 11, 33, 33)
+|}];;
(* Recursion (cf. PR#5291) *)
class a = let _ = new b in object end
and b = let _ = new a in object end;;
+[%%expect{|
+Line _, characters 10-37:
+ class a = let _ = new b in object end
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
+|}];;
class a = let _ = new a in object end;;
+[%%expect{|
+Line _, characters 10-37:
+ class a = let _ = new a in object end;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
+|}];;
+++ /dev/null
-
-# - : < x : int > ->
- < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int >
-= <fun>
-# class ['a] c : unit -> object constraint 'a = int method f : int c end
-and ['a] d : unit -> object constraint 'a = int method f : int c end
-# Characters 230-271:
- ....and d () = object
- inherit ['a] c ()
- end..
-Error: Some type variables are unbound in this type:
- class d : unit -> object method f : 'a -> unit end
- The method f has type 'a -> unit where 'a is unbound
-# class virtual c : unit -> object end
-and ['a] d :
- unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end
-# class ['a] c : unit -> object constraint 'a = int end
-and ['a] d : unit -> object constraint 'a = int #c end
-# * class ['a] c :
- 'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end
-# - : ('a c as 'a) -> 'a = <fun>
-# * Characters 128-176:
- class x () = object
- method virtual f : int
- end..
-Error: This class should be virtual. The following methods are undefined : f
-# Characters 144-152:
- class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end
- ^^^^^^^^
-Error: This pattern cannot match self: it only matches values of type
- < f : int >
-# Characters 32-110:
- class ['a] c () = object
- constraint 'a = int
- method f x = (x : bool c)
- end..
-Error: The abbreviation c is used with parameters bool c
- which are incompatible with constraints int c
-# class ['a, 'b] c :
- unit ->
- object
- constraint 'a = int -> 'c
- constraint 'b = 'a * < x : 'b > * 'c * 'd
- method f : 'a -> 'b -> unit
- end
-# class ['a, 'b] d :
- unit ->
- object
- constraint 'a = int -> 'c
- constraint 'b = 'a * < x : 'b > * 'c * 'd
- method f : 'a -> 'b -> unit
- end
-# val x : '_weak1 list ref = {contents = []}
-# Characters 0-50:
- class ['a] c () = object
- method f = (x : 'a)
- end..
-Error: The type of this class,
- class ['a] c :
- unit -> object constraint 'a = '_weak1 list ref method f : 'a end,
- contains type variables that cannot be generalized
-# Characters 21-53:
- type 'a c = <f : 'a c; g : 'a d>
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In the definition of d, type int c should be 'a c
-# type 'a c = < f : 'a c; g : 'a d >
-and 'a d = < f : 'a c >
-# type 'a c = < f : 'a c >
-and 'a d = < f : int c >
-# Characters 22-39:
- and 'a t = 'a t u;; (* fails since 4.04 *)
- ^^^^^^^^^^^^^^^^^
-Error: The definition of t contains a cycle:
- 'a t u
-# Characters 15-32:
- and 'a t = 'a t u;;
- ^^^^^^^^^^^^^^^^^
-Error: The type abbreviation t is cyclic
-# type 'a u = 'a
-# Characters 0-18:
- type t = t u * t u;;
- ^^^^^^^^^^^^^^^^^^
-Error: The type abbreviation t is cyclic
-# type t = < x : 'a > as 'a
-# type 'a u = 'a
-# - : t -> t u -> bool = <fun>
-# - : t -> t u -> bool = <fun>
-# module M :
- sig
- class ['a, 'b] c :
- int ->
- 'b ->
- object
- constraint 'a = int -> bool
- val x : float list
- val y : 'b
- method f : 'a -> unit
- method g : 'b
- end
- end
-# module M' :
- sig
- class virtual ['a, 'b] c :
- int ->
- 'b ->
- object
- constraint 'a = int -> bool
- val x : float list
- val y : 'b
- method f : 'a -> unit
- method g : 'b
- end
- end
-# class ['a, 'b] d :
- unit ->
- 'b ->
- object
- constraint 'a = int -> bool
- val x : float list
- val y : 'b
- method f : 'a -> unit
- method g : 'b
- end
-# class ['a, 'b] e :
- unit ->
- 'b ->
- object
- constraint 'a = int -> bool
- val x : float list
- val y : 'b
- method f : 'a -> unit
- method g : 'b
- end
-# - : string = "a"
-# - : int = 10
-# - : float = 7.1
-# # - : bool = true
-# module M : sig class ['a] c : unit -> object method f : 'a -> unit end end
-# module M' : sig class ['a] c : unit -> object method f : 'a -> unit end end
-# - : ('a #M.c as 'b) -> 'b = <fun>
-# - : ('a #M'.c as 'b) -> 'b = <fun>
-# class ['a] c : 'a #c -> object end
-# class ['a] c : 'a #c -> object end
-# class c : unit -> object method f : int end
-and d : unit -> object method f : int end
-# class e : unit -> object method f : int end
-# - : int = 2
-# Characters 30-34:
- class c () = object val x = - true val y = -. () end;;
- ^^^^
-Error: This expression has type bool but an expression was expected of type
- int
-# class c : unit -> object method f : int method g : int method h : int end
-# class d : unit -> object method h : int method i : int method j : int end
-# class e :
- unit ->
- object
- method f : int
- method g : int
- method h : int
- method i : int
- method j : int
- end
-# val e : e = <obj>
-# - : int * int * int * int * int = (1, 3, 2, 2, 3)
-# class c : 'a -> object val a : 'a val x : int val y : int val z : int end
-# class d : 'a -> object val b : 'a val t : int val u : int val z : int end
-# Characters 42-45:
- inherit c 5
- ^^^
-Warning 13: the following instance variables are overridden by the class c :
- x
-The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
-Characters 52-53:
- val y = 3
- ^
-Warning 13: the instance variable y is overridden.
-The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
-Characters 80-83:
- inherit d 7
- ^^^
-Warning 13: the following instance variables are overridden by the class d :
- t z
-The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
-Characters 90-91:
- val u = 3
- ^
-Warning 13: the instance variable u is overridden.
-The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
-class e :
- unit ->
- object
- val a : int
- val b : int
- val t : int
- val u : int
- val x : int
- val y : int
- val z : int
- method a : int
- method b : int
- method t : int
- method u : int
- method x : int
- method y : int
- method z : int
- end
-# val e : e = <obj>
-# - : int * int * int * int * int * int * int = (1, 3, 2, 2, 3, 5, 7)
-# class c :
- int ->
- int -> object val x : int val y : int method x : int method y : int end
-# class d :
- int ->
- int -> object val x : int val y : int method x : int method y : int end
-# - : int * int = (1, 2)
-# - : int * int = (1, 2)
-# class ['a] c : 'a -> object end
-# - : 'a -> 'a c = <fun>
-# * * * * * * * * * * * * * * * * * * * * * module M : sig class c : unit -> object method xc : int end end
-# class d : unit -> object val x : int method xc : int method xd : int end
-# - : int * int = (1, 2)
-# Characters 1-154:
- class virtual ['a] matrix (sz, init : int * 'a) = object
- val m = Array.make_matrix sz sz init
- method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a)
- end..
-Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a >
- but is used with type < m : 'a array array; .. >
-# class c : unit -> object method m : c end
-# - : c = <obj>
-# module M : sig class c : unit -> object method m : c end end
-# - : M.c = <obj>
-# type uu = A of int | B of (< leq : 'a > as 'a)
-# class virtual c : unit -> object ('a) method virtual m : 'a end
-# module S : sig val f : (#c as 'a) -> 'a end
-# Characters 12-43:
- ............struct
- let f (x : #c) = x
- end......
-Error: Signature mismatch:
- Modules do not match:
- sig val f : (#c as 'a) -> 'a end
- is not included in
- sig val f : #c -> #c end
- Values do not match:
- val f : (#c as 'a) -> 'a
- is not included in
- val f : #c -> #c
-# Characters 38-39:
- module M = struct type t = int class t () = object end end;;
- ^
-Error: Multiple definition of the type name t.
- Names must be unique in a given structure or signature.
-# - : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = <fun>
-# Characters 10-39:
- fun x -> (x : int -> bool :> 'a -> 'a);;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type int -> bool is not a subtype of int -> int
- Type bool is not a subtype of int
-# Characters 9-40:
- fun x -> (x : int -> bool :> int -> int);;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type int -> bool is not a subtype of int -> int
- Type bool is not a subtype of int
-# - : < > -> < > = <fun>
-# - : < .. > -> < > = <fun>
-# val x : '_weak2 list ref = {contents = []}
-# module F : functor (X : sig end) -> sig type t = int end
-# - : < m : int > list ref = {contents = []}
-# type 'a t
-# Characters 9-19:
- fun (x : 'a t as 'a) -> ();;
- ^^^^^^^^^^
-Error: This alias is bound to type 'a t but is used as an instance of type 'a
- The type variable 'a occurs inside 'a t
-# Characters 19-20:
- fun (x : 'a t) -> (x : 'a); ();;
- ^
-Error: This expression has type 'a t but an expression was expected of type
- 'a
- The type variable 'a occurs inside 'a t
-# type 'a t = < x : 'a >
-# - : ('a t as 'a) -> unit = <fun>
-# Characters 18-26:
- fun (x : 'a t) -> (x : 'a); ();;
- ^^^^^^^^
-Warning 10: this expression should have type unit.
-- : ('a t as 'a) t -> unit = <fun>
-# class ['a] c :
- unit ->
- object constraint 'a = (< .. > as 'b) -> unit method m : 'b -> unit end
-# class ['a] c :
- unit ->
- object constraint 'a = unit -> (< .. > as 'b) method m : 'a -> 'b end
-# class c : unit -> object method private m : int method n : int end
-# class d :
- unit -> object method private m : int method n : int method o : int end
-# - : int * int = (1, 1)
-# class c : unit -> object method m : int end
-# val r : int ref = {contents = 0}
-# val id : < .. > -> int = <fun>
-# - : unit = ()
-# - : int = 1
-# - : int = 2
-# - : int * int * int = (3, 4, 5)
-# - : int * int * int * int * int = (6, 7, 8, 33, 33)
-# - : int * int * int * int * int * int * int = (9, 10, 10, 11, 11, 33, 33)
-# Characters 42-69:
- class a = let _ = new b in object end
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of recursive class expression is not allowed
-# Characters 11-38:
- class a = let _ = new a in object end;;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of recursive class expression is not allowed
-#
+++ /dev/null
-
-# - : < x : int > ->
- < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int >
-= <fun>
-# class ['a] c : unit -> object constraint 'a = int method f : int c end
-and ['a] d : unit -> object constraint 'a = int method f : int c end
-# Characters 230-271:
- ....and d () = object
- inherit ['a] c ()
- end..
-Error: Some type variables are unbound in this type:
- class d : unit -> object method f : 'a -> unit end
- The method f has type 'a -> unit where 'a is unbound
-# class virtual c : unit -> object end
-and ['a] d :
- unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end
-# class ['a] c : unit -> object constraint 'a = int end
-and ['a] d : unit -> object constraint 'a = int #c end
-# * class ['a] c :
- 'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end
-# - : ('a c as 'a) -> 'a = <fun>
-# * Characters 128-176:
- class x () = object
- method virtual f : int
- end..
-Error: This class should be virtual. The following methods are undefined : f
-# Characters 144-152:
- class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end
- ^^^^^^^^
-Error: This pattern cannot match self: it only matches values of type
- < f : int >
-# Characters 32-110:
- class ['a] c () = object
- constraint 'a = int
- method f x = (x : bool c)
- end..
-Error: The abbreviation c is used with parameters bool c
- which are incompatible with constraints int c
-# class ['a, 'b] c :
- unit ->
- object
- constraint 'a = int -> 'c
- constraint 'b = 'a * < x : 'b > * 'c * 'd
- method f : 'a -> 'b -> unit
- end
-# class ['a, 'b] d :
- unit ->
- object
- constraint 'a = int -> 'c
- constraint 'b = 'a * < x : 'b > * 'c * 'd
- method f : 'a -> 'b -> unit
- end
-# val x : '_weak1 list ref = {contents = []}
-# Characters 0-50:
- class ['a] c () = object
- method f = (x : 'a)
- end..
-Error: The type of this class,
- class ['a] c :
- unit -> object constraint 'a = '_weak1 list ref method f : 'a end,
- contains type variables that cannot be generalized
-# Characters 21-53:
- type 'a c = <f : 'a c; g : 'a d>
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In the definition of d, type int c should be 'a c
-# type 'a c = < f : 'a c; g : 'a d >
-and 'a d = < f : 'a c >
-# type 'a c = < f : 'a c >
-and 'a d = < f : int c >
-# Characters 22-39:
- and 'a t = 'a t u;; (* fails since 4.04 *)
- ^^^^^^^^^^^^^^^^^
-Error: The definition of t contains a cycle:
- 'a t u
-# Characters 15-32:
- and 'a t = 'a t u;;
- ^^^^^^^^^^^^^^^^^
-Error: The type abbreviation t is cyclic
-# type 'a u = 'a
-# Characters 0-18:
- type t = t u * t u;;
- ^^^^^^^^^^^^^^^^^^
-Error: The type abbreviation t is cyclic
-# type t = < x : 'a > as 'a
-# type 'a u = 'a
-# - : t -> t u -> bool = <fun>
-# - : t -> t u -> bool = <fun>
-# module M :
- sig
- class ['a, 'b] c :
- int ->
- 'b ->
- object
- constraint 'a = int -> bool
- val x : float list
- val y : 'b
- method f : 'a -> unit
- method g : 'b
- end
- end
-# module M' :
- sig
- class virtual ['a, 'b] c :
- int ->
- 'b ->
- object
- constraint 'a = int -> bool
- val x : float list
- val y : 'b
- method f : 'a -> unit
- method g : 'b
- end
- end
-# class ['a, 'b] d :
- unit ->
- 'b ->
- object
- constraint 'a = int -> bool
- val x : float list
- val y : 'b
- method f : 'a -> unit
- method g : 'b
- end
-# class ['a, 'b] e :
- unit ->
- 'b ->
- object
- constraint 'a = int -> bool
- val x : float list
- val y : 'b
- method f : 'a -> unit
- method g : 'b
- end
-# - : string = "a"
-# - : int = 10
-# - : float = 7.1
-# # - : bool = true
-# module M : sig class ['a] c : unit -> object method f : 'a -> unit end end
-# module M' : sig class ['a] c : unit -> object method f : 'a -> unit end end
-# - : ('a #M.c as 'b) -> 'b = <fun>
-# - : ('a #M'.c as 'b) -> 'b = <fun>
-# class ['a] c : 'a #c -> object end
-# class ['a] c : 'a #c -> object end
-# class c : unit -> object method f : int end
-and d : unit -> object method f : int end
-# class e : unit -> object method f : int end
-# - : int = 2
-# Characters 30-34:
- class c () = object val x = - true val y = -. () end;;
- ^^^^
-Error: This expression has type bool but an expression was expected of type
- int
-# class c : unit -> object method f : int method g : int method h : int end
-# class d : unit -> object method h : int method i : int method j : int end
-# class e :
- unit ->
- object
- method f : int
- method g : int
- method h : int
- method i : int
- method j : int
- end
-# val e : e = <obj>
-# - : int * int * int * int * int = (1, 3, 2, 2, 3)
-# class c : 'a -> object val a : 'a val x : int val y : int val z : int end
-# class d : 'a -> object val b : 'a val t : int val u : int val z : int end
-# Characters 42-45:
- inherit c 5
- ^^^
-Warning 13: the following instance variables are overridden by the class c :
- x
-The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
-Characters 52-53:
- val y = 3
- ^
-Warning 13: the instance variable y is overridden.
-The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
-Characters 80-83:
- inherit d 7
- ^^^
-Warning 13: the following instance variables are overridden by the class d :
- t z
-The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
-Characters 90-91:
- val u = 3
- ^
-Warning 13: the instance variable u is overridden.
-The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
-class e :
- unit ->
- object
- val a : int
- val b : int
- val t : int
- val u : int
- val x : int
- val y : int
- val z : int
- method a : int
- method b : int
- method t : int
- method u : int
- method x : int
- method y : int
- method z : int
- end
-# val e : e = <obj>
-# - : int * int * int * int * int * int * int = (1, 3, 2, 2, 3, 5, 7)
-# class c :
- int ->
- int -> object val x : int val y : int method x : int method y : int end
-# class d :
- int ->
- int -> object val x : int val y : int method x : int method y : int end
-# - : int * int = (1, 2)
-# - : int * int = (1, 2)
-# class ['a] c : 'a -> object end
-# - : 'a -> 'a c = <fun>
-# * * * * * * * * * * * * * * * * * * * * * module M : sig class c : unit -> object method xc : int end end
-# class d : unit -> object val x : int method xc : int method xd : int end
-# - : int * int = (1, 2)
-# Characters 1-154:
- class virtual ['a] matrix (sz, init : int * 'a) = object
- val m = Array.make_matrix sz sz init
- method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a)
- end..
-Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a >
- but is used with type < m : 'a array array; .. >
-# class c : unit -> object method m : c end
-# - : c = <obj>
-# module M : sig class c : unit -> object method m : c end end
-# - : M.c = <obj>
-# type uu = A of int | B of (< leq : 'a > as 'a)
-# class virtual c : unit -> object ('a) method virtual m : 'a end
-# module S : sig val f : (#c as 'a) -> 'a end
-# Characters 12-43:
- ............struct
- let f (x : #c) = x
- end......
-Error: Signature mismatch:
- Modules do not match:
- sig val f : (#c as 'a) -> 'a end
- is not included in
- sig val f : #c -> #c end
- Values do not match:
- val f : (#c as 'a) -> 'a
- is not included in
- val f : #c -> #c
-# Characters 38-39:
- module M = struct type t = int class t () = object end end;;
- ^
-Error: Multiple definition of the type name t.
- Names must be unique in a given structure or signature.
-# - : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = <fun>
-# Characters 10-39:
- fun x -> (x : int -> bool :> 'a -> 'a);;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type int -> bool is not a subtype of int -> int
- Type bool is not a subtype of int
-# Characters 9-40:
- fun x -> (x : int -> bool :> int -> int);;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type int -> bool is not a subtype of int -> int
- Type bool is not a subtype of int
-# - : < > -> < > = <fun>
-# - : < .. > -> < > = <fun>
-# val x : '_weak2 list ref = {contents = []}
-# module F : functor (X : sig end) -> sig type t = int end
-# - : < m : int > list ref = {contents = []}
-# type 'a t
-# Characters 9-19:
- fun (x : 'a t as 'a) -> ();;
- ^^^^^^^^^^
-Error: This alias is bound to type 'a t but is used as an instance of type 'a
- The type variable 'a occurs inside 'a t
-# Characters 19-20:
- fun (x : 'a t) -> (x : 'a); ();;
- ^
-Error: This expression has type 'a t but an expression was expected of type
- 'a
- The type variable 'a occurs inside 'a t
-# type 'a t = < x : 'a >
-# - : ('a t as 'a) -> unit = <fun>
-# Characters 18-26:
- fun (x : 'a t) -> (x : 'a); ();;
- ^^^^^^^^
-Warning 10: this expression should have type unit.
-- : ('a t as 'a) t -> unit = <fun>
-# class ['a] c :
- unit ->
- object constraint 'a = (< .. > as 'b) -> unit method m : 'b -> unit end
-# class ['a] c :
- unit ->
- object constraint 'a = unit -> (< .. > as 'b) method m : 'a -> 'b end
-# class c : unit -> object method private m : int method n : int end
-# class d :
- unit -> object method private m : int method n : int method o : int end
-# - : int * int = (1, 1)
-# class c : unit -> object method m : int end
-# val r : int ref = {contents = 0}
-# val id : < .. > -> int = <fun>
-# - : unit = ()
-# - : int = 1
-# - : int = 2
-# - : int * int * int = (3, 4, 5)
-# - : int * int * int * int * int = (6, 7, 8, 33, 33)
-# - : int * int * int * int * int * int * int = (9, 10, 10, 11, 11, 33, 33)
-# Characters 42-69:
- class a = let _ = new b in object end
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of recursive class expression is not allowed
-# Characters 11-38:
- class a = let _ = new a in object end;;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This kind of recursive class expression is not allowed
-#
--- /dev/null
+(* TEST
+ * expect
+*)
+
+class virtual child1 parent =
+ object
+ method private parent = parent
+ end
+
+and virtual child2 =
+ object(_ : 'self)
+ constraint 'parent = < previous: 'self option; .. >
+ method private virtual parent: 'parent
+ end
+
+[%%expect{|
+class virtual child1 : 'a -> object method private parent : 'a end
+and virtual child2 :
+ object ('a)
+ method private virtual parent : < previous : 'a option; .. >
+ end
+|}]
+
+class virtual child1' parent =
+ object
+ method private parent = parent
+ end
+
+and virtual child2' =
+ object(_ : 'self)
+ constraint 'parent = < previous: 'self option; .. >
+ method private virtual parent: 'parent
+ end
+
+and foo = object(self)
+ method previous = None
+ method child =
+ object
+ inherit child1' self
+ inherit child2'
+ end
+end;;
+
+[%%expect{|
+Line _, characters 22-26:
+ inherit child1' self
+ ^^^^
+Error: This expression has type < child : 'a; previous : 'b option; .. >
+ but an expression was expected of type 'c
+ Self type cannot escape its class
+|}]
+
+(* Whether we have [class foo1] or [let foo1] doesn't change a thing. *)
+class foo1 = object(self)
+ method previous = None
+ method child =
+ object
+ inherit child1 self
+ inherit child2
+ end
+end;;
+[%%expect{|
+class foo1 : object method child : child2 method previous : child2 option end
+|}]
+
+class nested = object
+ method obj = object(self)
+ method previous = None
+ method child () =
+ object
+ inherit child1 self
+ inherit child2
+ end
+ end
+end;;
+[%%expect{|
+class nested :
+ object
+ method obj : < child : unit -> child2; previous : child2 option >
+ end
+|}]
+
+class just_to_see = object(self)
+ method previous = None
+ method child =
+ let o =
+ object
+ inherit child1 self
+ inherit child2
+ end
+ in
+ o
+end;;
+[%%expect{|
+class just_to_see :
+ object method child : child2 method previous : child2 option end
+|}]
+
+class just_to_see2 = object
+ method obj = object(self)
+ method previous = None
+ method child =
+ let o =
+ object
+ inherit child1 self
+ inherit child2
+ end
+ in
+ o
+ end
+end;;
+[%%expect{|
+class just_to_see2 :
+ object method obj : < child : child2; previous : child2 option > end
+|}]
+
+type gadt = Not_really_though : gadt
+
+class just_to_see3 = object(self)
+ method previous = None
+ method child Not_really_though =
+ object
+ inherit child1 self
+ inherit child2
+ end
+end;;
+[%%expect{|
+type gadt = Not_really_though : gadt
+class just_to_see3 :
+ object method child : gadt -> child2 method previous : child2 option end
+|}]
+
+class leading_up_to = object(self : 'a)
+ method previous : 'a option = None
+ method child =
+ object
+ inherit child1 self
+ inherit child2
+ end
+end;;
+[%%expect{|
+Line _, characters 4-65:
+ ....object
+ inherit child1 self
+ inherit child2
+ end
+Error: Cannot close type of object literal:
+ < child : '_weak1; previous : 'a option; _.. > as 'a
+ it has been unified with the self type of a class that is not yet
+ completely defined.
+|}]
+
+class assertion_failure = object(self : 'a)
+ method previous : 'a option = None
+ method child =
+ object
+ inherit child1 self
+ inherit child2
+
+ method previous = None
+ method child = assert false
+ end
+end;;
+[%%expect{|
+Line _, characters 4-129:
+ ....object
+ inherit child1 self
+ inherit child2
+
+ method previous = None
+ method child = assert false
+ end
+Error: Cannot close type of object literal:
+ < child : '_weak2; previous : 'a option; _.. > as 'a
+ it has been unified with the self type of a class that is not yet
+ completely defined.
+|}]
--- /dev/null
+dummy.ml
+Exemples.ml
+open_in_classes.ml
+pr5545.ml
+pr5619_bad.ml
+pr5858.ml
+pr6123_bad.ml
+pr6383.ml
+pr6907_bad.ml
+Tests.ml
+(* TEST
+ * expect
+*)
+
module M = struct
type t = int
let x = 42
end
;;
+[%%expect{|
+module M : sig type t = int val x : int end
+|}]
class c =
let open M in
object
method f : t = x
end
;;
+[%%expect{|
+class c : object method f : M.t end
+|}]
class type ct =
let open M in
object
method f : t
end
;;
+[%%expect{|
+class type ct = object method f : M.t end
+|}]
+++ /dev/null
-
-# module M : sig type t = int val x : int end
-# class c : object method f : M.t end
-# class type ct = object method f : M.t end
-#
+(* TEST
+ * expect
+*)
+
type foo = int;;
+[%%expect{|
+type foo = int
+|}]
class o =
object(this)
method x : foo = 10
method y : int = this # x
end;;
+[%%expect{|
+class o : object method x : foo method y : int end
+|}]
class o =
method x : foo = 10
method y = (this # x : int)
end;;
+[%%expect{|
+class o : object method x : foo method y : int end
+|}]
method x : int = (10 : int)
method y = (this # x : foo)
end;;
+[%%expect{|
+class o : object method x : int method y : foo end
+|}]
+++ /dev/null
-
-# type foo = int
-# class o : object method x : foo method y : int end
-# class o : object method x : foo method y : int end
-# class o : object method x : int method y : foo end
-#
+++ /dev/null
-
-# type foo = int
-# class o : object method x : foo method y : int end
-# class o : object method x : foo method y : int end
-# class o : object method x : int method y : foo end
-#
+(* TEST
+ * expect
+*)
+
class type foo_t =
object
method foo: string
| Int: int name
;;
+[%%expect{|
+class type foo_t = object method foo : string end
+type 'a name = Foo : foo_t name | Int : int name
+|}]
+
class foo =
object(self)
method foo = "foo"
Foo -> (self :> <foo : string>)
end
;;
+[%%expect{|
+class foo :
+ object method cast : foo_t name -> < foo : string > method foo : string end
+|}]
class foo: foo_t =
object(self)
| _ -> raise Exit
end
;;
+[%%expect{|
+Line _, characters 2-156:
+ ..object(self)
+ method foo = "foo"
+ method cast: type a. a name -> a =
+ function
+ Foo -> (self :> foo_t)
+ | _ -> raise Exit
+ end
+Error: The class type
+ object method cast : 'a name -> 'a method foo : string end
+ is not matched by the class type foo_t
+ The public method cast cannot be hidden
+|}]
+++ /dev/null
-
-# class type foo_t = object method foo : string end
-type 'a name = Foo : foo_t name | Int : int name
-# class foo :
- object method cast : foo_t name -> < foo : string > method foo : string end
-# Characters 22-176:
- ..object(self)
- method foo = "foo"
- method cast: type a. a name -> a =
- function
- Foo -> (self :> foo_t)
- | _ -> raise Exit
- end
-Error: The class type
- object method cast : 'a name -> 'a method foo : string end
- is not matched by the class type foo_t
- The public method cast cannot be hidden
-#
+++ /dev/null
-
-# class type foo_t = object method foo : string end
-type 'a name = Foo : foo_t name | Int : int name
-# class foo :
- object method cast : foo_t name -> < foo : string > method foo : string end
-# Characters 22-176:
- ..object(self)
- method foo = "foo"
- method cast: type a. a name -> a =
- function
- Foo -> (self :> foo_t)
- | _ -> raise Exit
- end
-Error: The class type
- object method cast : 'a name -> 'a method foo : string end
- is not matched by the class type foo_t
- The public method cast cannot be hidden
-#
+(* TEST
+ * expect
+*)
+
class type c = object end;;
+[%%expect{|
+class type c = object end
+|}]
+
module type S = sig class c: c end;;
+[%%expect{|
+Line _, characters 29-30:
+ module type S = sig class c: c end;;
+ ^
+Error: The class type c is not yet completely defined
+|}]
+++ /dev/null
-
-# class type c = object end
-# Characters 29-30:
- module type S = sig class c: c end;;
- ^
-Error: The class type c is not yet completely defined
-#
+(* TEST
+ * expect
+*)
+
class virtual name =
object
end
inherit name
end
;;
+[%%expect{|
+Line _, characters 50-54:
+ let args = List.map (fun ty -> new argument(self, ty)) args_ty in
+ ^^^^
+Error: This expression has type < arguments : 'a; .. >
+ but an expression was expected of type 'b
+ Self type cannot escape its class
+|}]
+++ /dev/null
-
-# Characters 253-257:
- let args = List.map (fun ty -> new argument(self, ty)) args_ty in
- ^^^^
-Error: This expression has type < arguments : 'a; .. >
- but an expression was expected of type 'b
- Self type cannot escape its class
-#
+++ /dev/null
-
-# Characters 253-257:
- let args = List.map (fun ty -> new argument(self, ty)) args_ty in
- ^^^^
-Error: This expression has type < arguments : 'a; .. >
- but an expression was expected of type 'b
- Self type cannot escape its class
-#
+(* TEST
+ * expect
+*)
+
let f (x: #M.foo) = 0;;
+[%%expect{|
+Line _, characters 11-16:
+ let f (x: #M.foo) = 0;;
+ ^^^^^
+Error: Unbound module M
+|}];;
+++ /dev/null
-
-# Characters 11-16:
- let f (x: #M.foo) = 0;;
- ^^^^^
-Error: Unbound module M
-#
+(* TEST
+ * expect
+*)
+
class type ['e] t = object('s)
method update : 'e -> 's
end;;
+[%%expect{|
+class type ['e] t = object ('a) method update : 'e -> 'a end
+|}];;
module type S = sig
class base : 'e -> ['e] t
end;;
+[%%expect{|
+Line _, characters 2-27:
+ class base : 'e -> ['e] t
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Some type variables are unbound in this type:
+ class base : 'e -> ['e] t
+ The method update has type 'e -> < update : 'a; .. > as 'a where 'e
+ is unbound
+|}];;
+++ /dev/null
-
-# class type ['e] t = object ('a) method update : 'e -> 'a end
-# Characters 23-48:
- class base : 'e -> ['e] t
- ^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Some type variables are unbound in this type:
- class base : 'e -> ['e] t
- The method update has type 'e -> < update : 'a; .. > as 'a where 'e
- is unbound
-#
--- /dev/null
+(* TEST
+ * expect
+*)
+
+type 'a r = <w: int -> int; .. > as 'a;;
+[%%expect{|
+type 'a r = 'a constraint 'a = < w : int -> int; .. >
+|}];;
+
+class type virtual ct = object('self)
+ constraint 'self = 'not_self r
+end;;
+[%%expect{|
+class type virtual ct = object method virtual w : int -> int end
+|}];;
+++ /dev/null
-# Check ocamlc -i
-
-SOURCES = pr7620_bad.ml
-
-all:
- @printf " ... testing '$(SOURCES)'"
- @$(OCAMLC) -i $(SOURCES) 2> /dev/null \
- && echo " => failed" || echo " => passed"
-
-clean: defaultclean
- @rm -f *~
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.common
-
--- /dev/null
+pr7620_bad.ml
--- /dev/null
+File "pr7620_bad.ml", line 10, characters 17-19:
+Error: This pattern matches values of type [? `B ]
+ but a pattern was expected which matches values of type [ `A ]
+ Types for tag `B are incompatible
+(* TEST
+flags = "-i"
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
let t =
(function `A | `B -> () : 'a) (`A : [`A]);
(failwith "dummy" : 'a) (* to know how 'a is unified *)
+++ /dev/null
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+pattern_open.ml
+(* TEST
+ * toplevel
+*)
+
let pp fmt = Printf.printf fmt
type 'a box = B of 'a
+++ /dev/null
-
-# val pp : ('a, out_channel, unit) format -> 'a = <fun>
-type 'a box = B of 'a
-module M : sig type c = C type t = { x : c box; } end
-# module N : sig type d = D val d : d type t = { x : d box; } end
-# val f : M.t -> 'a -> M.c * 'a = <fun>
-# val g : int -> int -> int = <fun>
-# val g : M.c list -> M.c list = <fun>
-# val h : M.c array -> M.c option = <fun>
-# val f2 : M.c box box -> M.c = <fun>
-# # # module L :
- sig
- type _ c = C : unit c
- type t = { t : unit c; }
- type r = { r : unit c; }
- val x : unit -> unit
- end
-# module K :
- sig
- type _ c = C : unit c
- type t = { t : unit c; }
- type r = { r : unit c; }
- val x : unit -> unit
- end
-# Right value K.x
-# module Exterior :
- sig
- module Gadt :
- sig
- module Boolean :
- sig
- type t = { b : bool; }
- type wrong = false | true
- val print : unit -> unit
- end
- type _ t =
- Bool : Boolean.t -> bool t
- | Int : int -> int t
- | Eq : 'a t * 'a t -> bool t
- val print : unit -> unit
- end
- val print : unit -> unit
- end
-# Right function print
-Right function print
-val eval : 't Exterior.Gadt.t -> 't = <fun>
-# module Existential :
- sig type printable = E : 'a * ('a -> unit) -> printable end
-val print : Existential.printable -> unit = <fun>
-# * module S :
- sig
- type 'a t = Sep : unit t
- type ex = Ex : 'a * 'a -> ex
- val s : unit t
- end
-# Characters 58-61:
- | S.(Sep), (S.(Sep,Sep), Sep) -> ()
- ^^^
-Error: Unbound constructor Sep
-# Characters 50-52:
- | S.(Ex(a,b)), Ex(c,d) -> ()
- ^^
-Error: Unbound constructor Ex
-# Characters 48-49:
- | S.(Sep) -> s
- ^
-Error: Unbound value s
-# module PR6437 :
- sig
- module Ctx :
- sig
- type ('a, 'b) t =
- Nil : (unit, unit) t
- | Cons : ('a, 'b) t -> ('a * unit, 'b * unit) t
- end
- module Var :
- sig type 'a t = O : ('a * unit) t | S : 'a t -> ('a * unit) t end
- end
-val f : ('g1, 'g2) PR6437.Ctx.t * 'g1 PR6437.Var.t -> 'g2 PR6437.Var.t =
- <fun>
-#
--- /dev/null
+val pp : ('a, out_channel, unit) format -> 'a = <fun>
+type 'a box = B of 'a
+module M : sig type c = C type t = { x : c box; } end
+module N : sig type d = D val d : d type t = { x : d box; } end
+val f : M.t -> 'a -> M.c * 'a = <fun>
+val g : int -> int -> int = <fun>
+val g : M.c list -> M.c list = <fun>
+val h : M.c array -> M.c option = <fun>
+val f2 : M.c box box -> M.c = <fun>
+module L :
+ sig
+ type _ c = C : unit c
+ type t = { t : unit c; }
+ type r = { r : unit c; }
+ val x : unit -> unit
+ end
+module K :
+ sig
+ type _ c = C : unit c
+ type t = { t : unit c; }
+ type r = { r : unit c; }
+ val x : unit -> unit
+ end
+Right value K.x
+module Exterior :
+ sig
+ module Gadt :
+ sig
+ module Boolean :
+ sig
+ type t = { b : bool; }
+ type wrong = false | true
+ val print : unit -> unit
+ end
+ type _ t =
+ Bool : Boolean.t -> bool t
+ | Int : int -> int t
+ | Eq : 'a t * 'a t -> bool t
+ val print : unit -> unit
+ end
+ val print : unit -> unit
+ end
+Right function print
+Right function print
+val eval : 't Exterior.Gadt.t -> 't = <fun>
+module Existential :
+ sig type printable = E : 'a * ('a -> unit) -> printable end
+val print : Existential.printable -> unit = <fun>
+module S :
+ sig
+ type 'a t = Sep : unit t
+ type ex = Ex : 'a * 'a -> ex
+ val s : unit t
+ end
+Characters 58-61:
+ | S.(Sep), (S.(Sep,Sep), Sep) -> ()
+ ^^^
+Error: Unbound constructor Sep
+Characters 50-52:
+ | S.(Ex(a,b)), Ex(c,d) -> ()
+ ^^
+Error: Unbound constructor Ex
+Characters 48-49:
+ | S.(Sep) -> s
+ ^
+Error: Unbound value s
+module PR6437 :
+ sig
+ module Ctx :
+ sig
+ type ('a, 'b) t =
+ Nil : (unit, unit) t
+ | Cons : ('a, 'b) t -> ('a * unit, 'b * unit) t
+ end
+ module Var :
+ sig type 'a t = O : ('a * unit) t | S : 'a t -> ('a * unit) t end
+ end
+val f : ('g1, 'g2) PR6437.Ctx.t * 'g1 PR6437.Var.t -> 'g2 PR6437.Var.t =
+ <fun>
+
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.okbad
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+pr5322_ok.ml
+pr5673_bad.ml
+pr5673_ok.ml
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
type 'par t = 'par
module M : sig val x : <m : 'a. 'a> end =
struct let x : <m : 'a. 'a t> = Obj.magic () end
--- /dev/null
+File "pr5673_bad.ml", line 31, characters 22-23:
+Error: This expression has type
+ refer1 = < poly : 'a 'b 'c. ('b, 'c) #Classdef.cl2 as 'a >
+ but an expression was expected of type
+ refer2 = < poly : 'd 'b 'c. ('b, 'c) #Classdef.cl2 as 'd >
+ Type
+ ('b, 'c) Classdef.cl1 =
+ < m : 'b -> 'c -> int; raise_trouble : int -> 'b >
+ is not compatible with type
+ < m : 'b -> 'c -> int; raise_trouble : int -> 'b >
+ The type variable 'e occurs inside 'e
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module Classdef = struct
class virtual ['a, 'b, 'c] cl0 =
object
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module Classdef = struct
class virtual ['a, 'b, 'c] cl0 =
object
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.expect
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * expect
+*)
+
(*
Polymorphic methods are now available in the main branch.
Enjoy.
end
|}, Principal{|
Line _, characters 4-16:
+ self#tl#fold ~f ~init:(f self#hd init)
+ ^^^^^^^^^^^^
Warning 18: this use of a polymorphic method is not principal.
class ['a] ostream1 :
hd:'a ->
val d : float = 11.
val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = <fun>
Line _, characters 41-42:
+ let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
+ ^
Error: This expression has type < m : 'b. 'b -> 'b list >
but an expression was expected of type < m : 'b. 'b -> 'c >
The universal variable 'b would escape its scope
;;
[%%expect {|
Line _, characters 12-17:
+ method id x = x
+ ^^^^^
Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
|}];;
;;
[%%expect {|
Line _, characters 12-17:
+ method id x = x
+ ^^^^^
Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
|}];;
;;
[%%expect {|
Line _, characters 12-17:
+ method id _ = x
+ ^^^^^
Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
|}];;
;;
[%%expect {|
Line _, characters 12-79:
+ ............x =
+ match r with
+ None -> r <- Some x; x
+ | Some y -> y
Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
|}];;
val f1 : id -> int * bool = <fun>
val f2 : id -> int * bool = <fun>
Line _, characters 24-28:
+ let f3 f = f#id 1, f#id true
+ ^^^^
Error: This expression has type bool but an expression was expected of type
int
|}];;
class id2 : object method id : 'a -> 'a method mono : int -> int end
val app : int * bool = (1, true)
Line _, characters 0-25:
+ type 'a foo = 'a foo list
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The type abbreviation foo is cyclic
|}];;
[%%expect {|
type bad = { bad : 'a. 'a option ref; }
Line _, characters 17-25:
+ let bad = {bad = ref None};;
+ ^^^^^^^^
Error: This field value has type 'b option ref which is less general than
'a. 'a option ref
|}];;
object method virtual visit : 'a.('a visitor -> 'a) end;;
[%%expect {|
Line _, characters 30-51:
+ object method virtual visit : 'a.('a visitor -> 'a) end;;
+ ^^^^^^^^^^^^^^^^^^^^^
Error: The universal type variable 'a cannot be generalized:
it escapes its scope.
|}];;
type t = u and u = t;;
[%%expect {|
Line _, characters 0-10:
+ type t = u and u = t;;
+ ^^^^^^^^^^
Error: The definition of t contains a cycle:
u
|}];;
type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
[%%expect {|
Line _, characters 50-59:
+ type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
+ ^^^^^^^^^
Error: Constraints are not satisfied in this type.
Type ('a, 'b) t should be an instance of ('c, 'c) t
|}];;
[%%expect {|
type 'a t constraint 'a = int
Line _, characters 26-32:
+ type 'a u = 'a and 'a v = 'a u t;;
+ ^^^^^^
Error: Constraints are not satisfied in this type.
Type 'a u t should be an instance of int t
|}];;
type g = int
type 'a t = unit constraint 'a = g
Line _, characters 26-32:
+ type 'a u = 'a and 'a v = 'a u t;;
+ ^^^^^^
Error: Constraints are not satisfied in this type.
Type 'a u t should be an instance of g t
|}];;
type 'a u = < m : 'a v > and 'a v = 'a list u;;
[%%expect {|
Line _, characters 0-24:
+ type 'a u = < m : 'a v > and 'a v = 'a list u;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^
Error: In the definition of v, type 'a list u should be 'a u
|}];;
type u = 'a t as 'a
|}];;
-
-(* Variant tests *)
-type t = A | B;;
-function `A,_ -> 1 | _,A -> 2 | _,B -> 3;;
-function `A,_ -> 1 | _,(A|B) -> 2;;
-function Some `A, _ -> 1 | Some _, A -> 2 | None, A -> 3 | _, B -> 4;;
-function Some `A, A -> 1 | Some `A, B -> 1
- | Some _, A -> 2 | None, A -> 3 | _, B -> 4;;
-function A, `A -> 1 | A, `B -> 2 | B, _ -> 3;;
-function `A, A -> 1 | `B, A -> 2 | _, B -> 3;;
-function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;;
-function `B,1 -> 1 | _,1 -> 2;;
-function 1,`B -> 1 | 1,_ -> 2;;
-[%%expect {|
-type t = A | B
-- : [> `A ] * t -> int = <fun>
-- : [> `A ] * t -> int = <fun>
-- : [> `A ] option * t -> int = <fun>
-- : [> `A ] option * t -> int = <fun>
-- : t * [< `A | `B ] -> int = <fun>
-- : [< `A | `B ] * t -> int = <fun>
-Line _, characters 0-41:
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-(`<some other tag>, `<some other tag>)
-- : [> `A | `B ] * [> `A | `B ] -> int = <fun>
-Line _, characters 0-29:
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-(_, 0)
-Line _, characters 21-24:
-Warning 11: this match case is unused.
-- : [< `B ] * int -> int = <fun>
-Line _, characters 0-29:
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-(0, _)
-Line _, characters 21-24:
-Warning 11: this match case is unused.
-- : int * [< `B ] -> int = <fun>
-|}];;
-
(* pass typetexp, but fails during Typedecl.check_recursion *)
type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b]
and ('a, 'b) b = 'b -> unit constraint 'b = [> `A of ('a, 'b) a as 'a];;
[%%expect {|
Line _, characters 0-71:
+ type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b]
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The definition of a contains a cycle:
[> `B of ('a, 'b) b as 'b ] as 'a
|}];;
val f : unit -> c = <fun>
val f : unit -> c = <fun>
Line _, characters 11-60:
+ let f () = object method private n = 1 method m = {<>}#n end;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 15: the following private methods were made public implicitly:
n.
val f : unit -> < m : int; n : int > = <fun>
Line _, characters 11-56:
+ let f () = object (self:c) method n = 1 method m = 2 end;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This object is expected to have type c but actually has type
< m : int; n : 'a >
The first object type has no method n
let f (x : foo') = (x : bar');;
[%%expect {|
Line _, characters 3-4:
+ (x : <m : 'a. 'a * (<m:'b. 'a * <m:'c. 'c * 'bar> > as 'bar) >);;
+ ^
Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
but an expression was expected of type
< m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
:> <m : 'a. 'a -> ('a * 'foo)> as 'foo);;
[%%expect {|
Line _, characters 3-4:
+ (x : <m : 'b. 'b * ('b * <m : 'c. 'c * ('c * 'bar)>)> as 'bar);;
+ ^
Error: This expression has type
< m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
but an expression was expected of type
= struct type t = <m : 'a. 'a * ('a * 'foo)> as 'foo end;;
[%%expect {|
Line _, characters 2-64:
+ = struct let f (x : <m : 'a. 'a * ('a * 'foo)> as 'foo) = () end;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
Modules do not match:
sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end
type u = private [< t ]
- : u -> v = <fun>
Line _, characters 9-21:
+ fun x -> (x : v :> u);;
+ ^^^^^^^^^^^^
Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ]
|}];;
(x : <m:'a. [< `A of < > ] as 'a> :> <m:'a. [< `A of <p:int> ] as 'a>);;
[%%expect {|
Line _, characters 2-88:
+ ..(x : <m:'a. (<p:int;..> as 'a) -> int>
+ :> <m:'b. (<p:int;q:int;..> as 'b) -> int>)..
Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
< m : 'b. (< p : int; q : int; .. > as 'b) -> int >
Type < p : int; q : int; .. > as 'c is not a subtype of
|}, Principal{|
val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun>
Line _, characters 9-16:
+ fun x -> (f x)#m;; (* Warning 18 *)
+ ^^^^^^^
Warning 18: this use of a polymorphic method is not principal.
- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = <fun>
Line _, characters 9-20:
+ fun x -> (f (x,x))#m;; (* Warning 18 *)
+ ^^^^^^^^^^^
Warning 18: this use of a polymorphic method is not principal.
- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = <fun>
Line _, characters 9-20:
+ fun x -> (f x).(0)#m;; (* Warning 18 *)
+ ^^^^^^^^^^^
Warning 18: this use of a polymorphic method is not principal.
- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
|}];;
type u = c option
val just : 'a option -> 'a = <fun>
Line _, characters 42-62:
+ let f x = let l = [Some x; (None : u)] in (just(List.hd l))#id;;
+ ^^^^^^^^^^^^^^^^^^^^
Warning 18: this use of a polymorphic method is not principal.
val f : c -> 'a -> 'a = <fun>
Line _, characters 36-47:
+ let x = List.hd [Some x; none] in (just x)#id;;
+ ^^^^^^^^^^^
Warning 18: this use of a polymorphic method is not principal.
val g : c -> 'a -> 'a = <fun>
val h : < id : 'a; .. > -> 'a = <fun>
type 'a t = Leaf of 'a | Node of ('a * 'a) t
val depth : 'a t -> int = <fun>
Line _, characters 2-42:
+ function Leaf _ -> 1 | Node x -> 1 + d x
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This definition has type 'a t -> int which is less general than
'a0. 'a0 t -> int
|}];;
val zero : t = {f = `Int 0}
type t = { f : 'a. [< `Int of int ] as 'a; }
Line _, characters 16-22:
+ let zero = {f = `Int 0} ;; (* fails *)
+ ^^^^^^
Error: This expression has type [> `Int of int ]
but an expression was expected of type [< `Int of int ]
Types for tag `Int are incompatible
type t = { f : 'a. 'a -> unit; }
- : t = {f = <fun>}
Line _, characters 19-20:
+ let f ?x y = y in {f};; (* fail *)
+ ^
Error: This field value has type unit -> unit which is less general than
'a. 'a -> unit
|}];;
type s = A of int
let (A x) = (raise Exit : s);;
[%%expect {|
-Exception: Pervasives.Exit.
+Exception: Stdlib.Pervasives.Exit.
|}];;
(* PR#5224 *)
type 'x t = < f : 'y. 'y t >;;
[%%expect {|
Line _, characters 0-28:
+ type 'x t = < f : 'y. 'y t >;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In the definition of t, type 'y t should be 'x t
|}];;
[%%expect {|
val n : < m : 'x 'a. ([< `Foo of 'x ] as 'a) -> 'x > = <obj>
|}];;
-(* ok, but not with -principal *)
+(* ok *)
let n =
object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
[%%expect {|
val n : < m : 'x. [< `Foo of 'x ] -> 'x > = <obj>
-|}, Principal{|
-Line _, characters 47-68:
-Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
- which is less general than 'x. 'a -> 'x
|}];;
(* fail *)
let (n : < m : 'a. [< `Foo of int] -> 'a >) =
object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
[%%expect {|
Line _, characters 2-72:
+ object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x >
but an expression was expected of type
< m : 'a. [< `Foo of int ] -> 'a >
The universal variable 'x would escape its scope
-|}, Principal{|
-Line _, characters 47-68:
-Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
- which is less general than 'x. 'a -> 'x
|}];;
(* fail *)
let (n : 'b -> < m : 'a . ([< `Foo of int] as 'b) -> 'a >) = fun x ->
object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
[%%expect {|
Line _, characters 2-72:
+ object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x >
but an expression was expected of type
< m : 'a. [< `Foo of int ] -> 'a >
The universal variable 'x would escape its scope
-|}, Principal{|
-Line _, characters 47-68:
-Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
- which is less general than 'x. 'a -> 'x
|}];;
(* PR#6171 *)
if b then x else M.A;;
[%%expect {|
Line _, characters 19-22:
+ if b then x else M.A;;
+ ^^^
Error: This expression has type M.t but an expression was expected of type 'x
The type constructor M.t would escape its scope
|}];;
and g = <a:t>
[%%expect{|
Line _, characters 10-11:
+ type t = <g>
+ ^
Error: The type constructor g
is not yet completely defined
|}]
[%%expect{|
type t = int
Line _, characters 10-11:
+ type g = <t>
+ ^
Error: The type int is not an object type
|}]
type gg = <a:int->float; a:int>
[%%expect{|
Line _, characters 27-30:
+ type gg = <a:int->float; a:int>
+ ^^^
Error: Method 'a' has type int, which should be int -> float
|}]
[%%expect{|
type t = < a : int; b : string >
Line _, characters 19-20:
+ type g = <b:float; t;>
+ ^
Error: Method 'b' has type string, which should be float
|}]
type t = < int #A.t1 >
[%%expect{|
Line _, characters 11-20:
+ type t = < int #A.t1 >
+ ^^^^^^^^^
Error: Illegal open object type
|}]
|}]
(* GPR#1142 *)
+external reraise : exn -> 'a = "%reraise"
+
module M () = struct
let f : 'a -> 'a = assert false
let g : 'a -> 'a = raise Not_found
+ let h : 'a -> 'a = reraise Not_found
+ let i : 'a -> 'a = raise_notrace Not_found
end
[%%expect{|
-module M : functor () -> sig val f : 'a -> 'a val g : 'a -> 'a end
+external reraise : exn -> 'a = "%reraise"
+module M :
+ functor () ->
+ sig
+ val f : 'a -> 'a
+ val g : 'a -> 'a
+ val h : 'a -> 'a
+ val i : 'a -> 'a
+ end
|}]
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-default:
- @printf " ... testing 'pr3918':"
- @($(OCAMLC) -c pr3918a.mli \
- && $(OCAMLC) -c pr3918b.mli \
- && $(OCAMLC) -c pr3918c.ml \
- && echo " => passed") || echo " => failed"
-
-clean: defaultclean
-
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+pr3918c.ml
--- /dev/null
+File "pr3918c.ml", line 24, characters 11-12:
+Error: This expression has type 'b Pr3918b.vlist = 'a
+ but an expression was expected of type 'b Pr3918b.vlist
+ The type variable 'a occurs inside 'a
+(* TEST
+files = "pr3918a.mli pr3918b.mli"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+module = "pr3918a.mli"
+*** ocamlc.byte
+module = "pr3918b.mli"
+**** script
+script = "rm -f pr3918a.cmi"
+***** ocamlc.byte
+module = "pr3918c.ml"
+ocamlc_byte_exit_status = "2"
+***** check-ocamlc.byte-output
+*)
+
(*
ocamlc -c pr3918a.mli pr3918b.mli
rm -f pr3918a.cmi
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.okbad
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+pr4775_ok.ml
+pr4933_ok.ml
+pr5057_ok.ml
+pr5057a_bad.ml
+pr7199_ok.ml
+privrowsabate_ok.ml
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type Poly = sig
type 'a t = 'a constraint 'a = [> ]
end
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type Priv = sig
type t = private int
end
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* PR5057 *)
module TT = struct
--- /dev/null
+File "pr5057a_bad.ml", line 14, characters 48-49:
+Error: This expression has type 'a but an expression was expected of type
+ int -> T.t -> bool
+ The type constructor T.t would escape its scope
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* This one should fail *)
let f flag =
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type S = sig
type +'a t
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
type 'a termpc =
[`And of 'a * 'a
|`Or of 'a * 'a
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.okbad
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+pr5026_bad.ml
+pr5469_ok.ml
--- /dev/null
+File "pr5026_bad.ml", line 11, characters 0-36:
+Error: The definition of wrapped contains a cycle:
+ sexp
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
type untyped;;
type -'a typed = private untyped;;
type -'typing wrapped = private sexp
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module M (T:sig type t end)
= struct type t = private { t : T.t } end
module P
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+private.ml
--- /dev/null
+module Foobar : sig type t = private int end
+module F0 : sig type t = private int end
+Characters 21-22:
+ let f (x : F0.t) = (x : Foobar.t);; (* fails *)
+ ^
+Error: This expression has type F0.t but an expression was expected of type
+ Foobar.t
+module F = Foobar
+val f : F.t -> Foobar.t = <fun>
+module M : sig type t = < m : int > end
+module M1 : sig type t = private < m : int; .. > end
+module M2 : sig type t = private < m : int; .. > end
+Characters 19-20:
+ fun (x : M1.t) -> (x : M2.t);; (* fails *)
+ ^
+Error: This expression has type M1.t but an expression was expected of type
+ M2.t
+module M3 : sig type t = private M1.t end
+- : M3.t -> M1.t = <fun>
+- : M3.t -> M.t = <fun>
+Characters 44-46:
+ module M4 : sig type t = private M3.t end = M2;; (* fails *)
+ ^^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type t = M2.t end
+ is not included in
+ sig type t = private M3.t end
+ Type declarations do not match:
+ type t = M2.t
+ is not included in
+ type t = private M3.t
+Characters 44-45:
+ module M4 : sig type t = private M3.t end = M;; (* fails *)
+ ^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type t = < m : int > end
+ is not included in
+ sig type t = private M3.t end
+ Type declarations do not match:
+ type t = < m : int >
+ is not included in
+ type t = private M3.t
+Characters 44-46:
+ module M4 : sig type t = private M3.t end = M1;; (* might be ok *)
+ ^^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type t = M1.t end
+ is not included in
+ sig type t = private M3.t end
+ Type declarations do not match:
+ type t = M1.t
+ is not included in
+ type t = private M3.t
+module M5 : sig type t = private M1.t end
+Characters 53-55:
+ module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *)
+ ^^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type t = M1.t end
+ is not included in
+ sig type t = private < n : int; .. > end
+ Type declarations do not match:
+ type t = M1.t
+ is not included in
+ type t = private < n : int; .. >
+Characters 69-118:
+ struct type t = int let f (x : int) = (x : t) end;; (* must fail *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type t = int val f : int -> t end
+ is not included in
+ sig type t = private Foobar.t val f : int -> t end
+ Type declarations do not match:
+ type t = int
+ is not included in
+ type t = private Foobar.t
+module M : sig type t = private T of int val mk : int -> t end
+module M1 : sig type t = M.t val mk : int -> t end
+module M2 : sig type t = M.t val mk : int -> t end
+module M3 : sig type t = M.t val mk : int -> t end
+Characters 21-44:
+ type t = M.t = T of int
+ ^^^^^^^^^^^^^^^^^^^^^^^
+Error: This variant or record definition does not match that of type M.t
+ A private type would be revealed.
+module M5 : sig type t = M.t = private T of int val mk : int -> t end
+module M6 : sig type t = private T of int val mk : int -> t end
+module M' :
+ sig type t_priv = private T of int type t = t_priv val mk : int -> t end
+module M3' : sig type t = M'.t val mk : int -> t end
+module M : sig type 'a t = private T of 'a end
+module M1 : sig type 'a t = 'a M.t = private T of 'a end
+module Test : sig type t = private A end
+module Test2 : sig type t = Test.t = private A end
+val f : Test.t -> Test2.t = <fun>
+val f : Test2.t -> unit = <fun>
+Characters 8-15:
+ let a = Test2.A;; (* fail *)
+ ^^^^^^^
+Error: Cannot create values of the private type Test2.t
+Characters 148-171:
+ module Test2 : module type of Test with type t = private Test.t = Test;;
+ ^^^^^^^^^^^^^^^^^^^^^^^
+Warning 3: deprecated: spurious use of private
+module Test2 : sig type t = Test.t = private A end
+type t = private < x : int; .. >
+type t = private < x : int; .. >
+type t = private < x : int >
+type t = private < x : int >
+Characters -1--1:
+ type 'a t = private < x : int; .. > as 'a;;
+
+Error: Type declarations do not match:
+ type 'a t = private 'a constraint 'a = < x : int; .. >
+ is not included in
+ type 'a t
+ Their constraints differ.
+type 'a t = private 'a constraint 'a = < x : int; .. >
+type t = [ `Closed ]
+type nonrec t = private [> t ]
+
--- /dev/null
+module Foobar : sig type t = private int end
+module F0 : sig type t = private int end
+Characters 21-22:
+ let f (x : F0.t) = (x : Foobar.t);; (* fails *)
+ ^
+Error: This expression has type F0.t but an expression was expected of type
+ Foobar.t
+module F = Foobar
+val f : F.t -> Foobar.t = <fun>
+module M : sig type t = < m : int > end
+module M1 : sig type t = private < m : int; .. > end
+module M2 : sig type t = private < m : int; .. > end
+Characters 19-20:
+ fun (x : M1.t) -> (x : M2.t);; (* fails *)
+ ^
+Error: This expression has type M1.t but an expression was expected of type
+ M2.t
+module M3 : sig type t = private M1.t end
+- : M3.t -> M1.t = <fun>
+- : M3.t -> M.t = <fun>
+Characters 44-46:
+ module M4 : sig type t = private M3.t end = M2;; (* fails *)
+ ^^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type t = M2.t end
+ is not included in
+ sig type t = private M3.t end
+ Type declarations do not match:
+ type t = M2.t
+ is not included in
+ type t = private M3.t
+Characters 44-45:
+ module M4 : sig type t = private M3.t end = M;; (* fails *)
+ ^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type t = < m : int > end
+ is not included in
+ sig type t = private M3.t end
+ Type declarations do not match:
+ type t = < m : int >
+ is not included in
+ type t = private M3.t
+Characters 44-46:
+ module M4 : sig type t = private M3.t end = M1;; (* might be ok *)
+ ^^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type t = M1.t end
+ is not included in
+ sig type t = private M3.t end
+ Type declarations do not match:
+ type t = M1.t
+ is not included in
+ type t = private M3.t
+module M5 : sig type t = private M1.t end
+Characters 53-55:
+ module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *)
+ ^^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type t = M1.t end
+ is not included in
+ sig type t = private < n : int; .. > end
+ Type declarations do not match:
+ type t = M1.t
+ is not included in
+ type t = private < n : int; .. >
+Characters 69-118:
+ struct type t = int let f (x : int) = (x : t) end;; (* must fail *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type t = int val f : int -> t end
+ is not included in
+ sig type t = private Foobar.t val f : int -> t end
+ Type declarations do not match:
+ type t = int
+ is not included in
+ type t = private Foobar.t
+module M : sig type t = private T of int val mk : int -> t end
+module M1 : sig type t = M.t val mk : int -> t end
+module M2 : sig type t = M.t val mk : int -> t end
+module M3 : sig type t = M.t val mk : int -> t end
+Characters 21-44:
+ type t = M.t = T of int
+ ^^^^^^^^^^^^^^^^^^^^^^^
+Error: This variant or record definition does not match that of type M.t
+ A private type would be revealed.
+module M5 : sig type t = M.t = private T of int val mk : int -> t end
+module M6 : sig type t = private T of int val mk : int -> t end
+module M' :
+ sig type t_priv = private T of int type t = t_priv val mk : int -> t end
+module M3' : sig type t = M'.t val mk : int -> t end
+module M : sig type 'a t = private T of 'a end
+module M1 : sig type 'a t = 'a M.t = private T of 'a end
+module Test : sig type t = private A end
+module Test2 : sig type t = Test.t = private A end
+val f : Test.t -> Test2.t = <fun>
+val f : Test2.t -> unit = <fun>
+Characters 8-15:
+ let a = Test2.A;; (* fail *)
+ ^^^^^^^
+Error: Cannot create values of the private type Test2.t
+Characters 148-171:
+ module Test2 : module type of Test with type t = private Test.t = Test;;
+ ^^^^^^^^^^^^^^^^^^^^^^^
+Warning 3: deprecated: spurious use of private
+module Test2 : sig type t = Test.t = private A end
+type t = private < x : int; .. >
+type t = private < x : int; .. >
+type t = private < x : int >
+type t = private < x : int >
+Characters -1--1:
+ type 'a t = private < x : int; .. > as 'a;;
+
+Error: Type declarations do not match:
+ type 'a t = private < x : int; .. > constraint 'a = 'a t
+ is not included in
+ type 'a t
+ Their constraints differ.
+type 'a t = private 'a constraint 'a = < x : int; .. >
+type t = [ `Closed ]
+type nonrec t = private [> t ]
+
+(* TEST
+ * toplevel
+ * toplevel with principal
+*)
+
module Foobar : sig
type t = private int
end = struct
+++ /dev/null
-
-# module Foobar : sig type t = private int end
-# module F0 : sig type t = private int end
-# Characters 21-22:
- let f (x : F0.t) = (x : Foobar.t);; (* fails *)
- ^
-Error: This expression has type F0.t but an expression was expected of type
- Foobar.t
-# module F = Foobar
-# val f : F.t -> Foobar.t = <fun>
-# module M : sig type t = < m : int > end
-# module M1 : sig type t = private < m : int; .. > end
-# module M2 : sig type t = private < m : int; .. > end
-# Characters 19-20:
- fun (x : M1.t) -> (x : M2.t);; (* fails *)
- ^
-Error: This expression has type M1.t but an expression was expected of type
- M2.t
-# module M3 : sig type t = private M1.t end
-# - : M3.t -> M1.t = <fun>
-# - : M3.t -> M.t = <fun>
-# Characters 44-46:
- module M4 : sig type t = private M3.t end = M2;; (* fails *)
- ^^
-Error: Signature mismatch:
- Modules do not match:
- sig type t = M2.t end
- is not included in
- sig type t = private M3.t end
- Type declarations do not match:
- type t = M2.t
- is not included in
- type t = private M3.t
-# Characters 44-45:
- module M4 : sig type t = private M3.t end = M;; (* fails *)
- ^
-Error: Signature mismatch:
- Modules do not match:
- sig type t = < m : int > end
- is not included in
- sig type t = private M3.t end
- Type declarations do not match:
- type t = < m : int >
- is not included in
- type t = private M3.t
-# Characters 44-46:
- module M4 : sig type t = private M3.t end = M1;; (* might be ok *)
- ^^
-Error: Signature mismatch:
- Modules do not match:
- sig type t = M1.t end
- is not included in
- sig type t = private M3.t end
- Type declarations do not match:
- type t = M1.t
- is not included in
- type t = private M3.t
-# module M5 : sig type t = private M1.t end
-# Characters 53-55:
- module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *)
- ^^
-Error: Signature mismatch:
- Modules do not match:
- sig type t = M1.t end
- is not included in
- sig type t = private < n : int; .. > end
- Type declarations do not match:
- type t = M1.t
- is not included in
- type t = private < n : int; .. >
-# Characters 69-118:
- struct type t = int let f (x : int) = (x : t) end;; (* must fail *)
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
- Modules do not match:
- sig type t = int val f : int -> t end
- is not included in
- sig type t = private Foobar.t val f : int -> t end
- Type declarations do not match:
- type t = int
- is not included in
- type t = private Foobar.t
-# module M : sig type t = private T of int val mk : int -> t end
-# module M1 : sig type t = M.t val mk : int -> t end
-# module M2 : sig type t = M.t val mk : int -> t end
-# module M3 : sig type t = M.t val mk : int -> t end
-# Characters 21-44:
- type t = M.t = T of int
- ^^^^^^^^^^^^^^^^^^^^^^^
-Error: This variant or record definition does not match that of type M.t
- A private type would be revealed.
-# module M5 : sig type t = M.t = private T of int val mk : int -> t end
-# module M6 : sig type t = private T of int val mk : int -> t end
-# module M' :
- sig type t_priv = private T of int type t = t_priv val mk : int -> t end
-# module M3' : sig type t = M'.t val mk : int -> t end
-# module M : sig type 'a t = private T of 'a end
-# module M1 : sig type 'a t = 'a M.t = private T of 'a end
-# module Test : sig type t = private A end
-module Test2 : sig type t = Test.t = private A end
-# val f : Test.t -> Test2.t = <fun>
-# val f : Test2.t -> unit = <fun>
-# Characters 8-15:
- let a = Test2.A;; (* fail *)
- ^^^^^^^
-Error: Cannot create values of the private type Test2.t
-# * Characters 148-171:
- module Test2 : module type of Test with type t = private Test.t = Test;;
- ^^^^^^^^^^^^^^^^^^^^^^^
-Warning 3: deprecated: spurious use of private
-module Test2 : sig type t = Test.t = private A end
-# type t = private < x : int; .. >
-# type t = private < x : int; .. >
-# type t = private < x : int >
-# type t = private < x : int >
-# Characters -1--1:
- type 'a t = private < x : int; .. > as 'a;;
-
-Error: Type declarations do not match:
- type 'a t = private 'a constraint 'a = < x : int; .. >
- is not included in
- type 'a t
- Their constraints differ.
-# type 'a t = private 'a constraint 'a = < x : int; .. >
-# type t = [ `Closed ]
-# type nonrec t = private [> t ]
-#
+++ /dev/null
-
-# module Foobar : sig type t = private int end
-# module F0 : sig type t = private int end
-# Characters 21-22:
- let f (x : F0.t) = (x : Foobar.t);; (* fails *)
- ^
-Error: This expression has type F0.t but an expression was expected of type
- Foobar.t
-# module F = Foobar
-# val f : F.t -> Foobar.t = <fun>
-# module M : sig type t = < m : int > end
-# module M1 : sig type t = private < m : int; .. > end
-# module M2 : sig type t = private < m : int; .. > end
-# Characters 19-20:
- fun (x : M1.t) -> (x : M2.t);; (* fails *)
- ^
-Error: This expression has type M1.t but an expression was expected of type
- M2.t
-# module M3 : sig type t = private M1.t end
-# - : M3.t -> M1.t = <fun>
-# - : M3.t -> M.t = <fun>
-# Characters 44-46:
- module M4 : sig type t = private M3.t end = M2;; (* fails *)
- ^^
-Error: Signature mismatch:
- Modules do not match:
- sig type t = M2.t end
- is not included in
- sig type t = private M3.t end
- Type declarations do not match:
- type t = M2.t
- is not included in
- type t = private M3.t
-# Characters 44-45:
- module M4 : sig type t = private M3.t end = M;; (* fails *)
- ^
-Error: Signature mismatch:
- Modules do not match:
- sig type t = < m : int > end
- is not included in
- sig type t = private M3.t end
- Type declarations do not match:
- type t = < m : int >
- is not included in
- type t = private M3.t
-# Characters 44-46:
- module M4 : sig type t = private M3.t end = M1;; (* might be ok *)
- ^^
-Error: Signature mismatch:
- Modules do not match:
- sig type t = M1.t end
- is not included in
- sig type t = private M3.t end
- Type declarations do not match:
- type t = M1.t
- is not included in
- type t = private M3.t
-# module M5 : sig type t = private M1.t end
-# Characters 53-55:
- module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *)
- ^^
-Error: Signature mismatch:
- Modules do not match:
- sig type t = M1.t end
- is not included in
- sig type t = private < n : int; .. > end
- Type declarations do not match:
- type t = M1.t
- is not included in
- type t = private < n : int; .. >
-# Characters 69-118:
- struct type t = int let f (x : int) = (x : t) end;; (* must fail *)
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
- Modules do not match:
- sig type t = int val f : int -> t end
- is not included in
- sig type t = private Foobar.t val f : int -> t end
- Type declarations do not match:
- type t = int
- is not included in
- type t = private Foobar.t
-# module M : sig type t = private T of int val mk : int -> t end
-# module M1 : sig type t = M.t val mk : int -> t end
-# module M2 : sig type t = M.t val mk : int -> t end
-# module M3 : sig type t = M.t val mk : int -> t end
-# Characters 21-44:
- type t = M.t = T of int
- ^^^^^^^^^^^^^^^^^^^^^^^
-Error: This variant or record definition does not match that of type M.t
- A private type would be revealed.
-# module M5 : sig type t = M.t = private T of int val mk : int -> t end
-# module M6 : sig type t = private T of int val mk : int -> t end
-# module M' :
- sig type t_priv = private T of int type t = t_priv val mk : int -> t end
-# module M3' : sig type t = M'.t val mk : int -> t end
-# module M : sig type 'a t = private T of 'a end
-# module M1 : sig type 'a t = 'a M.t = private T of 'a end
-# module Test : sig type t = private A end
-module Test2 : sig type t = Test.t = private A end
-# val f : Test.t -> Test2.t = <fun>
-# val f : Test2.t -> unit = <fun>
-# Characters 8-15:
- let a = Test2.A;; (* fail *)
- ^^^^^^^
-Error: Cannot create values of the private type Test2.t
-# * Characters 148-171:
- module Test2 : module type of Test with type t = private Test.t = Test;;
- ^^^^^^^^^^^^^^^^^^^^^^^
-Warning 3: deprecated: spurious use of private
-module Test2 : sig type t = Test.t = private A end
-# type t = private < x : int; .. >
-# type t = private < x : int; .. >
-# type t = private < x : int >
-# type t = private < x : int >
-# Characters -1--1:
- type 'a t = private < x : int; .. > as 'a;;
-
-Error: Type declarations do not match:
- type 'a t = private < x : int; .. > constraint 'a = 'a t
- is not included in
- type 'a t
- Their constraints differ.
-# type 'a t = private 'a constraint 'a = < x : int; .. >
-# type t = [ `Closed ]
-# type nonrec t = private [> t ]
-#
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.okbad
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+t01bad.ml
+t02bad.ml
+t03ok.ml
+t04bad.ml
+t05bad.ml
+t06ok.ml
+t07bad.ml
+t08bad.ml
+t09bad.ml
+t10ok.ml
+t11bad.ml
+t12bad.ml
+t13ok.ml
+t14bad.ml
+t15bad.ml
+t16ok.ml
+t17ok.ml
+t18ok.ml
+t19ok.ml
+t20ok.ml
+t21ok.ml
+t22ok.ml
--- /dev/null
+File "t01bad.ml", line 10, characters 15-35:
+Error: The type abbreviation A.t is cyclic
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Bad (t = t) *)
module rec A : sig type t = A.t end = struct type t = A.t end;;
--- /dev/null
+File "t02bad.ml", line 10, characters 15-35:
+Error: The definition of A.t contains a cycle:
+ B.t
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Bad (t = t) *)
module rec A : sig type t = B.t end = struct type t = B.t end
and B : sig type t = A.t end = struct type t = A.t end;;
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* OK (t = int) *)
module rec A : sig type t = B.t end = struct type t = B.t end
and B : sig type t = int end = struct type t = int end;;
--- /dev/null
+File "t04bad.ml", line 10, characters 15-41:
+Error: The definition of A.t contains a cycle:
+ int * A.t
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Bad (t = int * t) *)
module rec A : sig type t = int * A.t end = struct type t = int * A.t end;;
--- /dev/null
+File "t05bad.ml", line 10, characters 15-42:
+Error: The definition of A.t contains a cycle:
+ B.t -> int
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Bad (t = t -> int) *)
module rec A : sig type t = B.t -> int end = struct type t = B.t -> int end
and B : sig type t = A.t end = struct type t = A.t end;;
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* OK (t = <m:t>) *)
module rec A : sig type t = <m:B.t> end = struct type t = <m:B.t> end
and B : sig type t = A.t end = struct type t = A.t end;;
--- /dev/null
+File "t07bad.ml", line 10, characters 15-51:
+Error: In the definition of A.t, type 'a list A.t should be 'a A.t
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Bad (not regular) *)
module rec A : sig type 'a t = <m: 'a list A.t> end
= struct type 'a t = <m: 'a list A.t> end;;
--- /dev/null
+File "t08bad.ml", line 10, characters 15-68:
+Error: In the definition of B.t, type 'a array A.t should be 'a A.t
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Bad (not regular) *)
module rec A : sig type 'a t = <m: 'a list B.t; n: 'a array B.t> end
= struct type 'a t = <m: 'a list B.t; n: 'a array B.t> end
--- /dev/null
+File "t09bad.ml", line 10, characters 15-41:
+Error: In the definition of B.t, type 'a array A.t should be 'a A.t
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Bad (not regular) *)
module rec A : sig type 'a t = 'a B.t end
= struct type 'a t = 'a B.t end
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* OK *)
module rec A : sig type 'a t = 'a array B.t * 'a list B.t end
= struct type 'a t = 'a array B.t * 'a list B.t end
--- /dev/null
+File "t11bad.ml", line 12, characters 15-52:
+Error: In the definition of B.t, type 'a array B.t should be 'a B.t
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Bad (not regular) *)
module rec A : sig type 'a t = 'a list B.t end
= struct type 'a t = 'a list B.t end
--- /dev/null
+File "t12bad.ml", line 11, characters 4-101:
+Error: In the definition of M.c, type 'b M.c should be 'a M.c
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Bad (not regular) *)
module rec M :
sig
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* OK *)
class type [ 'node ] extension = object method node : 'node end
class type [ 'ext ] node = object constraint 'ext = 'ext node #extension end
--- /dev/null
+File "t14bad.ml", line 23, characters 17-37:
+Error: The definition of U.D.t contains a cycle:
+ U'.t
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Bad - PR 4261 *)
module PR_4261 = struct
--- /dev/null
+File "t15bad.ml", line 11, characters 15-35:
+Error: The type abbreviation M.t is cyclic
+(* TEST
+flags = " -w a "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Bad - PR 4512 *)
module type S' = sig type t = int end
module rec M : S' with type t = M.t = struct type t = M.t end;;
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* PR#4450 *)
module PR_4450_1 = struct
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* A synthetic example of bootstrapped data structure
(suggested by J-C Filliatre) *)
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* PR 4470: simplified from OMake's sources *)
module rec DirElt
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* PR 4758, PR 4266 *)
module PR_4758 = struct
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* PR 4557 *)
module PR_4557 = struct
module F ( X : Set.OrderedType ) = struct
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module F ( X : Set.OrderedType ) = struct
module rec Mod : sig
module XSet :
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
(* Tests for recursive modules *)
let test number result expected =
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+recordarg.ml
+(* TEST
+ * toplevel
+*)
+
type t = A of {x:int; mutable y:int};;
let f (A r) = r;; (* -> escape *)
let f (A r) = r.x;; (* ok *)
+++ /dev/null
-
-# type t = A of { x : int; mutable y : int; }
-# Characters 14-15:
- let f (A r) = r;; (* -> escape *)
- ^
-Error: This form is not allowed as the type of the inlined record could escape.
-# val f : t -> int = <fun>
-# val f : int -> t = <fun>
-# val f : t -> t = <fun>
-# Characters 14-15:
- let f () = A {a = 1};; (* customized error message *)
- ^
-Error: The field a is not part of the record argument for the t.A constructor
-# val f : unit -> t = <fun>
-# type _ t = A : { x : 'a; y : 'b; } -> 'a t
-# val f : 'a t -> 'a t = <fun>
-# val f : 'a t -> 'a t = <fun>
-# module M :
- sig
- type 'a t = A of { x : 'a; } | B : { u : 'b; } -> unit t
- exception Foo of { x : int; }
- end
-# module N :
- sig
- type 'b t = 'b M.t = A of { x : 'b; } | B : { u : 'bla; } -> unit t
- exception Foo of { x : int; }
- end
-# module type S = sig exception A of { x : int; } end
-# Characters 65-74:
- module A = (val X.x)
- ^^^^^^^^^
-Error: This expression creates fresh types.
- It is not allowed inside applicative functors.
-# Characters 61-62:
- exception A of {x : string}
- ^
-Error: Multiple definition of the extension constructor name A.
- Names must be unique in a given structure or signature.
-# Characters 58-59:
- exception A of {x : string}
- ^
-Error: Multiple definition of the extension constructor name A.
- Names must be unique in a given structure or signature.
-# module M1 : sig exception A of { x : int; } end
-# Characters 34-44:
- include M1
- ^^^^^^^^^^
-Error: Multiple definition of the extension constructor name A.
- Names must be unique in a given structure or signature.
-# module type S1 = sig exception A of { x : int; } end
-# Characters 36-46:
- include S1
- ^^^^^^^^^^
-Error: Multiple definition of the extension constructor name A.
- Names must be unique in a given structure or signature.
-# module M : sig exception A of { x : int; } end
-# module X1 : sig type t = .. end
-# module X2 : sig type t = .. end
-# Characters 62-63:
- type X2.t += A of {x: int}
- ^
-Error: Multiple definition of the extension constructor name A.
- Names must be unique in a given structure or signature.
-# type _ c = C : [ `A ] c
-type t = T : { x : [< `A ] c; } -> t
-# val f : t -> unit = <fun>
-#
--- /dev/null
+type t = A of { x : int; mutable y : int; }
+Characters 14-15:
+ let f (A r) = r;; (* -> escape *)
+ ^
+Error: This form is not allowed as the type of the inlined record could escape.
+val f : t -> int = <fun>
+val f : int -> t = <fun>
+val f : t -> t = <fun>
+Characters 14-15:
+ let f () = A {a = 1};; (* customized error message *)
+ ^
+Error: The field a is not part of the record argument for the t.A constructor
+val f : unit -> t = <fun>
+type _ t = A : { x : 'a; y : 'b; } -> 'a t
+val f : 'a t -> 'a t = <fun>
+val f : 'a t -> 'a t = <fun>
+module M :
+ sig
+ type 'a t = A of { x : 'a; } | B : { u : 'b; } -> unit t
+ exception Foo of { x : int; }
+ end
+module N :
+ sig
+ type 'b t = 'b M.t = A of { x : 'b; } | B : { u : 'bla; } -> unit t
+ exception Foo of { x : int; }
+ end
+module type S = sig exception A of { x : int; } end
+Characters 65-74:
+ module A = (val X.x)
+ ^^^^^^^^^
+Error: This expression creates fresh types.
+ It is not allowed inside applicative functors.
+Characters 61-62:
+ exception A of {x : string}
+ ^
+Error: Multiple definition of the extension constructor name A.
+ Names must be unique in a given structure or signature.
+Characters 58-59:
+ exception A of {x : string}
+ ^
+Error: Multiple definition of the extension constructor name A.
+ Names must be unique in a given structure or signature.
+module M1 : sig exception A of { x : int; } end
+Characters 34-44:
+ include M1
+ ^^^^^^^^^^
+Error: Multiple definition of the extension constructor name A.
+ Names must be unique in a given structure or signature.
+module type S1 = sig exception A of { x : int; } end
+Characters 36-46:
+ include S1
+ ^^^^^^^^^^
+Error: Multiple definition of the extension constructor name A.
+ Names must be unique in a given structure or signature.
+module M : sig exception A of { x : int; } end
+module X1 : sig type t = .. end
+module X2 : sig type t = .. end
+Characters 62-63:
+ type X2.t += A of {x: int}
+ ^
+Error: Multiple definition of the extension constructor name A.
+ Names must be unique in a given structure or signature.
+type _ c = C : [ `A ] c
+type t = T : { x : [< `A ] c; } -> t
+val f : t -> unit = <fun>
+
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common
-COMPFLAGS = -rectypes
--- /dev/null
+pr5343_bad.ml
+pr6174_bad.ml
+pr6870_bad.ml
--- /dev/null
+File "pr5343_bad.ml", line 11, characters 2-14:
+Error: The type abbreviation u is cyclic
+(* TEST
+flags = " -w a -rectypes "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module M : sig
type 'a t
type u = u t and v = v t
--- /dev/null
+File "pr6174_bad.ml", line 11, characters 24-25:
+Error: This expression has type $0 but an expression was expected of type
+ $1 = ($2 -> $1) -> $1
+(* TEST
+flags = " -w a -rectypes "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
let f : type a o. ((a -> o) -> o) t -> (a -> o) -> o =
fun C k -> k (fun x -> x);;
--- /dev/null
+File "pr6870_bad.ml", line 10, characters 38-50:
+Error: This alias is bound to type 'a T.t but is used as an instance of type
+ 'a
+ The type variable 'a occurs inside 'a T.t
+(* TEST
+flags = " -w a -rectypes "
+ocamlc_byte_exit_status = "2"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
module type T = sig type 'a t end
module Fix (T : T) = struct type r = ('r T.t as 'r) end
+++ /dev/null
-# Check safety of linking
-
-SOURCES = a.ml b_bad.ml
-OBJECTS = $(SOURCES:%.ml=%.cmo)
-
-all: a.cmo
- @printf " ... testing 'b_bad.ml'"
- @$(OCAMLC) $(ADD_COMPFLAGS) -c -safe-string -warn-error +8 b_bad.ml 2> /dev/null \
- && echo " => failed" || echo " => passed"
-
-clean:
- @rm -f *.cmo *.cmi
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+File "b_bad.ml", line 13, characters 29-66:
+Error (warning 8): this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Y
+File "b_bad.ml", line 17, characters 11-14:
+Error: Unbound value A.y
+(* TEST
+files = "a.ml"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+module = "a.ml"
+*** ocamlc.byte
+module = "b_bad.ml"
+flags = "-safe-string -warn-error +8"
+ocamlc_byte_exit_status = "2"
+**** check-ocamlc.byte-output
+*)
+
let f : string A.t -> unit = function
A.X s -> print_endline s
--- /dev/null
+let message = "Hello, world!"
--- /dev/null
+redefine_largefile.ml
--- /dev/null
+(* TEST
+ modules = "largeFile.ml"
+*)
+print_string LargeFile.message
--- /dev/null
+Hello, world!
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
-TOPFLAGS = -short-paths
-
-default: gpr1223_foo.cmi gpr1223_bar.cmi
-
-gpr1223_bar.cmi: gpr1223_foo.cmi
--- /dev/null
+val y : Gpr1223_bar.N.O.t = Gpr1223_bar.N.O.T
+val x : Gpr1223_bar.M.t = Gpr1223_bar.M.T
+
+(* TEST
+ flags = " -short-paths "
+ modules = "gpr1223_foo.mli gpr1223_bar.mli"
+ * toplevel
+*)
let y = Gpr1223_bar.N.O.T;;
+++ /dev/null
-
-# val y : Gpr1223_bar.N.O.t = Gpr1223_bar.N.O.T
-# val x : Gpr1223_bar.M.t = Gpr1223_bar.M.T
-#
--- /dev/null
+gpr1223.ml
+pr5918.ml
+pr6836.ml
+pr7543.ml
+short-paths.ml
--- /dev/null
+Characters 136-146:
+ let _ = { a = () }
+ ^^^^^^^^^^
+Error: Some record fields are undefined: b
+
+(* TEST
+ flags = " -short-paths "
+ * toplevel
+*)
+
module rec A : sig
type t
end = struct
+++ /dev/null
-
-# Characters 82-92:
- let _ = { a = () }
- ^^^^^^^^^^
-Error: Some record fields are undefined: b
-#
--- /dev/null
+type t = [ `A | `B ]
+type 'a u = t
+val a : [< t > `A ] = `A
+type 'a s = 'a
+val b : [< t > `B ] = `B
+
+(* TEST
+ flags = " -short-paths "
+ * toplevel
+*)
+
type t = [`A | `B];;
type 'a u = t;;
let a : [< int u] = `A;;
+++ /dev/null
-
-# type t = [ `A | `B ]
-# type 'a u = t
-# val a : [< t > `A ] = `A
-# type 'a s = 'a
-# val b : [< t > `B ] = `B
-#
--- /dev/null
+module type S = sig type t end
+module N : sig type 'a t = 'a end
+val f : (module S with type t = unit) -> unit = <fun>
+Characters 19-20:
+ let () = f (module N);;
+ ^
+Error: Signature mismatch:
+ Modules do not match:
+ sig type 'a t = 'a end
+ is not included in
+ sig type t = N.t end
+ Type declarations do not match:
+ type 'a t = 'a
+ is not included in
+ type t = N.t
+ They have different arities.
+
+(* TEST
+ flags = " -short-paths "
+ * toplevel
+*)
+
(** Test that short-path printtyp does not fail on packed module.
Packed modules does not respect the arity of type constructor, which can break
+++ /dev/null
-
-# * * * * module type S = sig type t end
-# module N : sig type 'a t = 'a end
-# val f : (module S with type t = unit) -> unit = <fun>
-# Characters 19-20:
- let () = f (module N);;
- ^
-Error: Signature mismatch:
- Modules do not match:
- sig type 'a t = 'a end
- is not included in
- sig type t = N.t end
- Type declarations do not match:
- type 'a t = 'a
- is not included in
- type t = N.t
- They have different arities.
-#
--- /dev/null
+module Core :
+ sig
+ module Int :
+ sig
+ module T :
+ sig
+ type t = int
+ val compare : 'a -> 'a -> t
+ val ( + ) : t -> t -> t
+ end
+ type t = int
+ val compare : 'a -> 'a -> t
+ val ( + ) : t -> t -> t
+ module Map :
+ sig
+ type key = t
+ type 'a t = 'a Map.Make(T).t
+ val empty : 'a t
+ val is_empty : 'a t -> bool
+ val mem : key -> 'a t -> bool
+ val add : key -> 'a -> 'a t -> 'a t
+ val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
+ val singleton : key -> 'a -> 'a t
+ val remove : key -> 'a t -> 'a t
+ val merge :
+ (key -> 'a option -> 'b option -> 'c option) ->
+ 'a t -> 'b t -> 'c t
+ val union :
+ (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
+ val compare : ('a -> 'a -> key) -> 'a t -> 'a t -> key
+ val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+ val iter : (key -> 'a -> unit) -> 'a t -> unit
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val for_all : (key -> 'a -> bool) -> 'a t -> bool
+ val exists : (key -> 'a -> bool) -> 'a t -> bool
+ val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+ val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+ val cardinal : 'a t -> key
+ val bindings : 'a t -> (key * 'a) list
+ val min_binding : 'a t -> key * 'a
+ val min_binding_opt : 'a t -> (key * 'a) option
+ val max_binding : 'a t -> key * 'a
+ val max_binding_opt : 'a t -> (key * 'a) option
+ val choose : 'a t -> key * 'a
+ val choose_opt : 'a t -> (key * 'a) option
+ val split : key -> 'a t -> 'a t * 'a option * 'a t
+ val find : key -> 'a t -> 'a
+ val find_opt : key -> 'a t -> 'a option
+ val find_first : (key -> bool) -> 'a t -> key * 'a
+ val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
+ val find_last : (key -> bool) -> 'a t -> key * 'a
+ val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
+ val map : ('a -> 'b) -> 'a t -> 'b t
+ val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+ val to_seq : 'a t -> (key * 'a) Seq.t
+ val to_seq_from : key -> 'a t -> (key * 'a) Seq.t
+ val add_seq : (key * 'a) Seq.t -> 'a t -> 'a t
+ val of_seq : (key * 'a) Seq.t -> 'a t
+ end
+ end
+ module Std : sig module Int = Int end
+ end
+val x : 'a Int.Map.t = <abstr>
+Characters 8-9:
+ let y = x + x ;;
+ ^
+Error: This expression has type 'a Int.Map.t
+ but an expression was expected of type int
+module M : sig type t = A type u = C end
+module N : sig type t = B end
+- : M.t = A
+- : N.t = B
+- : u = C
+type t = M.t = A
+type u = M.u = C
+- : u = C
+module L : sig type v = V end
+- : v = V
+module L : sig type v = V end
+- : v = V
+type t1 = A
+module M1 : sig type u = v and v = t1 end
+module N1 : sig type u = v and v = t1 end
+type t1 = B
+module N2 : sig type u = v and v = N1.v end
+module type PR6566 = sig type t = string end
+module PR6566 : sig type t = int end
+Characters 26-32:
+ module PR6566' : PR6566 = PR6566;;
+ ^^^^^^
+Error: Signature mismatch:
+ Modules do not match: sig type t = int end is not included in PR6566
+ Type declarations do not match:
+ type t = int
+ is not included in
+ type t = string
+module A : sig module B : sig type t = T end end
+module M2 : sig type u = A.B.t type foo = int type v = u end
+
+(* TEST
+ flags = " -short-paths "
+ * toplevel
+*)
+
module Core = struct
module Int = struct
module T = struct
+++ /dev/null
-
-# module Core :
- sig
- module Int :
- sig
- module T :
- sig
- type t = int
- val compare : 'a -> 'a -> t
- val ( + ) : t -> t -> t
- end
- type t = int
- val compare : 'a -> 'a -> t
- val ( + ) : t -> t -> t
- module Map :
- sig
- type key = t
- type 'a t = 'a Map.Make(T).t
- val empty : 'a t
- val is_empty : 'a t -> bool
- val mem : key -> 'a t -> bool
- val add : key -> 'a -> 'a t -> 'a t
- val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
- val singleton : key -> 'a -> 'a t
- val remove : key -> 'a t -> 'a t
- val merge :
- (key -> 'a option -> 'b option -> 'c option) ->
- 'a t -> 'b t -> 'c t
- val union :
- (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
- val compare : ('a -> 'a -> key) -> 'a t -> 'a t -> key
- val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
- val iter : (key -> 'a -> unit) -> 'a t -> unit
- val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
- val for_all : (key -> 'a -> bool) -> 'a t -> bool
- val exists : (key -> 'a -> bool) -> 'a t -> bool
- val filter : (key -> 'a -> bool) -> 'a t -> 'a t
- val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
- val cardinal : 'a t -> key
- val bindings : 'a t -> (key * 'a) list
- val min_binding : 'a t -> key * 'a
- val min_binding_opt : 'a t -> (key * 'a) option
- val max_binding : 'a t -> key * 'a
- val max_binding_opt : 'a t -> (key * 'a) option
- val choose : 'a t -> key * 'a
- val choose_opt : 'a t -> (key * 'a) option
- val split : key -> 'a t -> 'a t * 'a option * 'a t
- val find : key -> 'a t -> 'a
- val find_opt : key -> 'a t -> 'a option
- val find_first : (key -> bool) -> 'a t -> key * 'a
- val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
- val find_last : (key -> bool) -> 'a t -> key * 'a
- val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
- val map : ('a -> 'b) -> 'a t -> 'b t
- val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
- end
- end
- module Std : sig module Int = Int end
- end
-# # val x : 'a Int.Map.t = <abstr>
-# Characters 8-9:
- let y = x + x ;;
- ^
-Error: This expression has type 'a Int.Map.t
- but an expression was expected of type int
-# module M : sig type t = A type u = C end
-module N : sig type t = B end
-# - : M.t = A
-# - : N.t = B
-# - : u = C
-# type t = M.t = A
-type u = M.u = C
-# - : u = C
-# module L : sig type v = V end
-# - : v = V
-# module L : sig type v = V end
-# - : v = V
-# type t1 = A
-# module M1 : sig type u = v and v = t1 end
-# module N1 : sig type u = v and v = t1 end
-# type t1 = B
-# module N2 : sig type u = v and v = N1.v end
-# module type PR6566 = sig type t = string end
-# module PR6566 : sig type t = int end
-# Characters 26-32:
- module PR6566' : PR6566 = PR6566;;
- ^^^^^^
-Error: Signature mismatch:
- Modules do not match: sig type t = int end is not included in PR6566
- Type declarations do not match:
- type t = int
- is not included in
- type t = string
-# module A : sig module B : sig type t = T end end
-# module M2 : sig type u = A.B.t type foo = int type v = u end
-#
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * toplevel
+*)
+
(* Adapted from: An Expressive Language of Signatures
by Norman Ramsey, Kathleen Fisher and Paul Govereau *)
+++ /dev/null
-
-# * module type VALUE = sig type value type state type usert end
-# module type CORE0 =
- sig
- module V : VALUE
- val setglobal : V.state -> string -> V.value -> unit
- end
-# module type CORE =
- sig
- module V : VALUE
- val setglobal : V.state -> string -> V.value -> unit
- val apply : V.value -> V.state -> V.value list -> V.value
- end
-# module type AST =
- sig
- module Value : VALUE
- type chunk
- type program
- val get_value : chunk -> Value.value
- end
-# module type EVALUATOR =
- sig
- module Value : VALUE
- module Ast :
- sig type chunk type program val get_value : chunk -> Value.value end
- type state = Value.state
- type value = Value.value
- exception Error of string
- val compile : Ast.program -> string
- val setglobal : Value.state -> string -> Value.value -> unit
- end
-# module type PARSER = sig type chunk val parse : string -> chunk end
-# module type INTERP =
- sig
- module Value : VALUE
- module Ast :
- sig type chunk type program val get_value : chunk -> Value.value end
- type state = Value.state
- type value = Value.value
- exception Error of string
- val compile : Ast.program -> string
- val setglobal : Value.state -> string -> Value.value -> unit
- module Parser :
- sig type chunk = Ast.chunk val parse : string -> chunk end
- val dostring : state -> string -> value list
- val mk : unit -> state
- end
-# module type USERTYPE =
- sig type t val eq : t -> t -> bool val to_string : t -> string end
-# module type TYPEVIEW =
- sig type combined type t val map : (combined -> t) * (t -> combined) end
-# module type COMBINED_COMMON =
- sig
- module T : sig type t end
- module TV1 : sig type t val map : (T.t -> t) * (t -> T.t) end
- module TV2 : sig type t val map : (T.t -> t) * (t -> T.t) end
- end
-# module type COMBINED_TYPE =
- sig
- module T : USERTYPE
- module TV1 : sig type t val map : (T.t -> t) * (t -> T.t) end
- module TV2 : sig type t val map : (T.t -> t) * (t -> T.t) end
- end
-# module type BARECODE = sig type state val init : state -> unit end
-# module USERCODE :
- functor (X : TYPEVIEW) ->
- sig
- module type F =
- functor
- (C : sig
- module V :
- sig type value type state type usert = X.combined end
- val setglobal : V.state -> string -> V.value -> unit
- val apply : V.value -> V.state -> V.value list -> V.value
- end) ->
- sig val init : C.V.state -> unit end
- end
-# module Weapon : sig type t end
-# module type WEAPON_LIB =
- sig
- type t = Weapon.t
- module T :
- sig type t = t val eq : t -> t -> bool val to_string : t -> string end
- module Make :
- functor
- (TV : sig
- type combined
- type t = t
- val map : (combined -> t) * (t -> combined)
- end) ->
- USERCODE(TV).F
- end
-# module type X = functor (X : CORE) -> BARECODE
-# module type X = CORE -> BARECODE
-#
--- /dev/null
+module type VALUE = sig type value type state type usert end
+module type CORE0 =
+ sig
+ module V : VALUE
+ val setglobal : V.state -> string -> V.value -> unit
+ end
+module type CORE =
+ sig
+ module V : VALUE
+ val setglobal : V.state -> string -> V.value -> unit
+ val apply : V.value -> V.state -> V.value list -> V.value
+ end
+module type AST =
+ sig
+ module Value : VALUE
+ type chunk
+ type program
+ val get_value : chunk -> Value.value
+ end
+module type EVALUATOR =
+ sig
+ module Value : VALUE
+ module Ast :
+ sig type chunk type program val get_value : chunk -> Value.value end
+ type state = Value.state
+ type value = Value.value
+ exception Error of string
+ val compile : Ast.program -> string
+ val setglobal : Value.state -> string -> Value.value -> unit
+ end
+module type PARSER = sig type chunk val parse : string -> chunk end
+module type INTERP =
+ sig
+ module Value : VALUE
+ module Ast :
+ sig type chunk type program val get_value : chunk -> Value.value end
+ type state = Value.state
+ type value = Value.value
+ exception Error of string
+ val compile : Ast.program -> string
+ val setglobal : Value.state -> string -> Value.value -> unit
+ module Parser :
+ sig type chunk = Ast.chunk val parse : string -> chunk end
+ val dostring : state -> string -> value list
+ val mk : unit -> state
+ end
+module type USERTYPE =
+ sig type t val eq : t -> t -> bool val to_string : t -> string end
+module type TYPEVIEW =
+ sig type combined type t val map : (combined -> t) * (t -> combined) end
+module type COMBINED_COMMON =
+ sig
+ module T : sig type t end
+ module TV1 : sig type t val map : (T.t -> t) * (t -> T.t) end
+ module TV2 : sig type t val map : (T.t -> t) * (t -> T.t) end
+ end
+module type COMBINED_TYPE =
+ sig
+ module T : USERTYPE
+ module TV1 : sig type t val map : (T.t -> t) * (t -> T.t) end
+ module TV2 : sig type t val map : (T.t -> t) * (t -> T.t) end
+ end
+module type BARECODE = sig type state val init : state -> unit end
+module USERCODE :
+ functor (X : TYPEVIEW) ->
+ sig
+ module type F =
+ functor
+ (C : sig
+ module V :
+ sig type value type state type usert = X.combined end
+ val setglobal : V.state -> string -> V.value -> unit
+ val apply : V.value -> V.state -> V.value list -> V.value
+ end) ->
+ sig val init : C.V.state -> unit end
+ end
+module Weapon : sig type t end
+module type WEAPON_LIB =
+ sig
+ type t = Weapon.t
+ module T :
+ sig type t = t val eq : t -> t -> bool val to_string : t -> string end
+ module Make :
+ functor
+ (TV : sig
+ type combined
+ type t = t
+ val map : (combined -> t) * (t -> combined)
+ end) ->
+ USERCODE(TV).F
+ end
+module type X = functor (X : CORE) -> BARECODE
+module type X = CORE -> BARECODE
+
--- /dev/null
+els.ml
+pr6371.ml
+pr6672.ml
+(* TEST
+ * toplevel
+*)
+
module M = struct
type t = int * (< m : 'a > as 'a)
end;;
+++ /dev/null
-
-# module M : sig type t = int * (< m : 'a > as 'a) end
-# module type S = sig module M : sig type t = int * (< m : 'a > as 'a) end end
-#
--- /dev/null
+module M : sig type t = int * (< m : 'a > as 'a) end
+module type S = sig module M : sig type t = int * (< m : 'a > as 'a) end end
+
+(* TEST
+ * toplevel
+*)
+
module type S = sig type 'a t end;;
module type T = S with type +'a t = 'a list;;
module type T = S with type -'a t = 'a list;;
+++ /dev/null
-
-# module type S = sig type 'a t end
-# module type T = sig type 'a t = 'a list end
-# Characters 23-43:
- module type T = S with type -'a t = 'a list;;
- ^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, expected parameter variances are not satisfied.
- The 1st type parameter was expected to be contravariant,
- but it is injective covariant.
-#
--- /dev/null
+module type S = sig type 'a t end
+module type T = sig type 'a t = 'a list end
+Characters 23-43:
+ module type T = S with type -'a t = 'a list;;
+ ^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, expected parameter variances are not satisfied.
+ The 1st type parameter was expected to be contravariant,
+ but it is injective covariant.
+
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.expect
-include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+sigsubst.ml
+(* TEST
+ * expect
+*)
+
module type Printable = sig
type t
val print : Format.formatter -> t -> unit
end
[%%expect {|
Line _, characters 2-36:
+ include Comparable with type t = t
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Multiple definition of the type name t.
Names must be unique in a given structure or signature.
|}]
end with type M.t = int
[%%expect {|
Line _, characters 17-115:
+ .................sig
+ module rec M : sig type t = M2.t end
+ and M2 : sig type t = int end
+ end with type M.t = int
Error: In this `with' constraint, the new definition of M.t
does not match its original definition in the constrained signature:
Type declarations do not match:
[%%expect {|
type 'a t constraint 'a = 'b list
Line _, characters 16-142:
+ ................sig
+ type 'a t2 constraint 'a = 'b list
+ type 'a mylist = 'a list
+ val x : int mylist t2
+ end with type 'a t2 := 'a t * bool
Error: Destructive substitutions are not supported for constrained
types (other than when replacing a type constructor with
a type constructor with the same arguments).
end with type M.t := float
[%%expect {|
Line _, characters 16-89:
+ ................sig
+ module M : sig type t end
+ module A = M
+ end with type M.t := float
Error: This `with' constraint on M.t changes M, which is aliased
in the constrained signature (as A).
|}]
module type S2 = S with type M.t := float
[%%expect {|
Line _, characters 17-41:
+ module type S2 = S with type M.t := float
+ ^^^^^^^^^^^^^^^^^^^^^^^^
Error: This `with' constraint on M.t makes the applicative functor
type F(M).t ill-typed in the constrained signature:
Modules do not match:
[%%expect {|
module Id : functor (X : sig type t end) -> sig type t = X.t end
Line _, characters 17-120:
+ .................sig
+ module rec M : sig type t = A of Id(M2).t end
+ and M2 : sig type t end
+ end with type M2.t := int
Error: This `with' constraint on M2.t makes the applicative functor
type Id(M2).t ill-typed in the constrained signature:
Modules do not match: sig end is not included in sig type t end
end with module M.N := A
[%%expect {|
Line _, characters 16-159:
+ ................sig
+ module M : sig
+ module N : sig
+ module P : sig
+ type t
+ end
+ end
+ end
+ module Alias = M
+ end with module M.N := A
Error: This `with' constraint on M.N changes M, which is aliased
in the constrained signature (as Alias).
|}]
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * toplevel
+*)
+
let property (type t) () =
let module M = struct exception E of t end in
(fun x -> M.E x), (function M.E x -> Some x | _ -> None)
+++ /dev/null
-
-# val property : unit -> ('a -> exn) * (exn -> 'a option) = <fun>
-# false
-true
-true
-false
-# val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list = <fun>
-# abc,xyz
-# Characters 33-34:
- let f x (type a) (y : a) = (x = y);; (* Fails *)
- ^
-Error: This expression has type a but an expression was expected of type 'a
- The type constructor a would escape its scope
-# Characters 117-118:
- method n : 'a -> 'a = fun (type g) (x:g) -> self#m x
- ^
-Error: This expression has type g but an expression was expected of type 'a
- The type constructor g would escape its scope
-#
--- /dev/null
+val property : unit -> ('a -> exn) * (exn -> 'a option) = <fun>
+false
+true
+true
+false
+val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list = <fun>
+abc,xyz
+Characters 33-34:
+ let f x (type a) (y : a) = (x = y);; (* Fails *)
+ ^
+Error: This expression has type a but an expression was expected of type 'a
+ The type constructor a would escape its scope
+Characters 117-118:
+ method n : 'a -> 'a = fun (type g) (x:g) -> self#m x
+ ^
+Error: This expression has type g but an expression was expected of type 'a
+ The type constructor g would escape its scope
+
--- /dev/null
+newtype.ml
+++ /dev/null
-newdefault: test.ml.reference
- @$(MAKE) default
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
-
-GENERATED_SOURCES = test.ml.reference *.flat-float
-
-ifeq "$(FLAT_FLOAT_ARRAY)" "true"
-suffix = -flat
-else
-suffix = -noflat
-endif
-
-test.ml.reference: test.ml.reference$(suffix) $(FLAT_FLOAT_ARRAY).flat-float
- @cp $< $@
-
-%.flat-float:
- @rm -f $(GENERATED_SOURCES)
- @touch $@
+(* TEST
+ * flat-float-array
+ ** toplevel
+ compiler_reference = "${test_source_directory}/test.ml.reference-flat"
+ * no-flat-float-array
+ ** toplevel
+ compiler_reference = "${test_source_directory}/test.ml.reference-noflat"
+*)
+
(* Check the unboxing *)
(* For concrete types *)
type ('a, 'p) t = private 'a s
type 'a packed = T : ('a, _) t -> 'a packed [@@unboxed]
;;
+
+(* MPR#7682 *)
+type f = {field: 'a. 'a list} [@@unboxed];;
+let g = Array.make 10 { field=[] };;
+let h = g.(5);;
+
+(* Using [@@immediate] information (GPR#1469) *)
+type 'a t [@@immediate];;
+type u = U : 'a t -> u [@@unboxed];;
-
-# type t1 = A of string [@@unboxed]
-# - : bool = true
-# type t2 = { f : string; } [@@unboxed]
-# - : bool = true
-# type t3 = B of { g : string; } [@@unboxed]
-# - : bool = true
-# Characters 29-58:
+type t1 = A of string [@@unboxed]
+- : bool = true
+type t2 = { f : string; } [@@unboxed]
+- : bool = true
+type t3 = B of { g : string; } [@@unboxed]
+- : bool = true
+Characters 29-58:
type t4 = C [@@ocaml.unboxed];; (* no argument *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because its constructor has no argument.
-# Characters 0-45:
+Characters 0-45:
type t5 = D of int * string [@@ocaml.unboxed];; (* more than one argument *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because
its constructor has more than one argument.
-# Characters 0-33:
+Characters 0-33:
type t5 = E | F [@@ocaml.unboxed];; (* more than one constructor *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because it has more than one constructor.
-# Characters 0-40:
+Characters 0-40:
type t6 = G of int | H [@@ocaml.unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because it has more than one constructor.
-# Characters 0-51:
+Characters 0-51:
type t7 = I of string | J of bool [@@ocaml.unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because it has more than one constructor.
-# Characters 1-50:
+Characters 1-50:
type t8 = { h : bool; i : int } [@@ocaml.unboxed];; (* more than one field *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because it has more than one field.
-# Characters 0-56:
+Characters 0-56:
type t9 = K of { j : string; l : int } [@@ocaml.unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because
its constructor has more than one argument.
-# type t10 = A of t10 [@@unboxed]
-# Characters 12-15:
+type t10 = A of t10 [@@unboxed]
+Characters 12-15:
let rec x = A x;;
^^^
Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 121-172:
+Characters 121-172:
......struct
type t = A of string [@@ocaml.unboxed]
end..
type t = A of string
Their internal representations differ:
the first declaration uses unboxed representation.
-# Characters 63-96:
+Characters 63-96:
......struct
type t = A of string
end..
type t = A of string [@@unboxed]
Their internal representations differ:
the second declaration uses unboxed representation.
-# Characters 48-102:
+Characters 48-102:
......struct
type t = { f : string } [@@ocaml.unboxed]
end..
type t = { f : string; }
Their internal representations differ:
the first declaration uses unboxed representation.
-# Characters 66-102:
+Characters 66-102:
......struct
type t = { f : string }
end..
type t = { f : string; } [@@unboxed]
Their internal representations differ:
the second declaration uses unboxed representation.
-# Characters 53-112:
+Characters 53-112:
......struct
type t = A of { f : string } [@@ocaml.unboxed]
end..
type t = A of { f : string; }
Their internal representations differ:
the first declaration uses unboxed representation.
-# Characters 71-112:
+Characters 71-112:
......struct
type t = A of { f : string }
end..
type t = A of { f : string; } [@@unboxed]
Their internal representations differ:
the second declaration uses unboxed representation.
-# type t11 = L of float [@@unboxed]
-# - : unit = ()
-# type 'a t12 = M of 'a t12 [@@unboxed]
-# val f : int t12 array -> int t12 = <fun>
-# type t13 = A : 'a t12 -> t13 [@@unboxed]
-# type t14
-# type t15 = A of t14 [@@unboxed]
-# type 'a abs
-# Characters 0-45:
+type t11 = L of float [@@unboxed]
+- : unit = ()
+type 'a t12 = M of 'a t12 [@@unboxed]
+val f : int t12 array -> int t12 = <fun>
+type t13 = A : 'a t12 -> t13 [@@unboxed]
+type t14
+type t15 = A of t14 [@@unboxed]
+type 'a abs
+Characters 0-45:
type t16 = A : _ abs -> t16 [@@ocaml.unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because
it might contain both float and non-float values.
You should annotate it with [@@ocaml.boxed].
-# Characters 19-69:
+Characters 19-69:
type t18 = A : _ list abs -> t18 [@@ocaml.unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because
it might contain both float and non-float values.
You should annotate it with [@@ocaml.boxed].
-# * Characters 176-256:
+Characters 176-256:
......struct
type t = A of float [@@ocaml.unboxed]
type u = { f1 : t; f2 : t }
type u = { f1 : t; f2 : t; }
Their internal representations differ:
the first declaration uses unboxed float representation.
-# * * module T : sig type t [@@immediate] end
-# * type 'a s = S : 'a -> 'a s [@@unboxed]
-# Characters 0-33:
+module T : sig type t [@@immediate] end
+type 'a s = S : 'a -> 'a s [@@unboxed]
+Characters 0-33:
type t = T : _ s -> t [@@unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because
it might contain both float and non-float values.
You should annotate it with [@@ocaml.boxed].
-# type 'a s = S : 'a -> 'a option s [@@unboxed]
-# Characters 0-33:
+type 'a s = S : 'a -> 'a option s [@@unboxed]
+Characters 0-33:
type t = T : _ s -> t [@@unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because
it might contain both float and non-float values.
You should annotate it with [@@ocaml.boxed].
-# module M :
+module M :
sig type 'a r constraint 'a = unit -> 'b val inj : 'b -> (unit -> 'b) r end
-# Characters 14-59:
+Characters 14-59:
type t = T : (unit -> _) M.r -> t [@@unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because
it might contain both float and non-float values.
You should annotate it with [@@ocaml.boxed].
-# type 'a s = S : (unit -> 'a) M.r -> 'a option s [@@unboxed]
-# Characters 14-47:
+type 'a s = S : (unit -> 'a) M.r -> 'a option s [@@unboxed]
+Characters 14-47:
type t = T : _ s -> t [@@unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because
it might contain both float and non-float values.
You should annotate it with [@@ocaml.boxed].
-# type 'a t = T : 'a s -> 'a t [@@unboxed]
-# Characters 42-81:
+type 'a t = T : 'a s -> 'a t [@@unboxed]
+Characters 42-81:
type _ s = S : 'a t -> _ s [@@unboxed]
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because
it might contain both float and non-float values.
You should annotate it with [@@ocaml.boxed].
-# type 'a s
+type 'a s
type ('a, 'p) t = private 'a s
type 'a packed = T : ('a, 'b) t -> 'a packed [@@unboxed]
-#
+type f = { field : 'a. 'a list; } [@@unboxed]
+val g : f array =
+ [|{field = []}; {field = []}; {field = []}; {field = []}; {field = []};
+ {field = []}; {field = []}; {field = []}; {field = []}; {field = []}|]
+val h : f = {field = []}
+type 'a t [@@immediate]
+type u = U : 'a t -> u [@@unboxed]
+
-
-# type t1 = A of string [@@unboxed]
-# - : bool = true
-# type t2 = { f : string; } [@@unboxed]
-# - : bool = true
-# type t3 = B of { g : string; } [@@unboxed]
-# - : bool = true
-# Characters 29-58:
+type t1 = A of string [@@unboxed]
+- : bool = true
+type t2 = { f : string; } [@@unboxed]
+- : bool = true
+type t3 = B of { g : string; } [@@unboxed]
+- : bool = true
+Characters 29-58:
type t4 = C [@@ocaml.unboxed];; (* no argument *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because its constructor has no argument.
-# Characters 0-45:
+Characters 0-45:
type t5 = D of int * string [@@ocaml.unboxed];; (* more than one argument *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because
its constructor has more than one argument.
-# Characters 0-33:
+Characters 0-33:
type t5 = E | F [@@ocaml.unboxed];; (* more than one constructor *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because it has more than one constructor.
-# Characters 0-40:
+Characters 0-40:
type t6 = G of int | H [@@ocaml.unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because it has more than one constructor.
-# Characters 0-51:
+Characters 0-51:
type t7 = I of string | J of bool [@@ocaml.unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because it has more than one constructor.
-# Characters 1-50:
+Characters 1-50:
type t8 = { h : bool; i : int } [@@ocaml.unboxed];; (* more than one field *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because it has more than one field.
-# Characters 0-56:
+Characters 0-56:
type t9 = K of { j : string; l : int } [@@ocaml.unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because
its constructor has more than one argument.
-# type t10 = A of t10 [@@unboxed]
-# Characters 12-15:
+type t10 = A of t10 [@@unboxed]
+Characters 12-15:
let rec x = A x;;
^^^
Error: This kind of expression is not allowed as right-hand side of `let rec'
-# Characters 121-172:
+Characters 121-172:
......struct
type t = A of string [@@ocaml.unboxed]
end..
type t = A of string
Their internal representations differ:
the first declaration uses unboxed representation.
-# Characters 63-96:
+Characters 63-96:
......struct
type t = A of string
end..
type t = A of string [@@unboxed]
Their internal representations differ:
the second declaration uses unboxed representation.
-# Characters 48-102:
+Characters 48-102:
......struct
type t = { f : string } [@@ocaml.unboxed]
end..
type t = { f : string; }
Their internal representations differ:
the first declaration uses unboxed representation.
-# Characters 66-102:
+Characters 66-102:
......struct
type t = { f : string }
end..
type t = { f : string; } [@@unboxed]
Their internal representations differ:
the second declaration uses unboxed representation.
-# Characters 53-112:
+Characters 53-112:
......struct
type t = A of { f : string } [@@ocaml.unboxed]
end..
type t = A of { f : string; }
Their internal representations differ:
the first declaration uses unboxed representation.
-# Characters 71-112:
+Characters 71-112:
......struct
type t = A of { f : string }
end..
type t = A of { f : string; } [@@unboxed]
Their internal representations differ:
the second declaration uses unboxed representation.
-# type t11 = L of float [@@unboxed]
-# - : unit = ()
-# type 'a t12 = M of 'a t12 [@@unboxed]
-# val f : int t12 array -> int t12 = <fun>
-# type t13 = A : 'a t12 -> t13 [@@unboxed]
-# type t14
-# type t15 = A of t14 [@@unboxed]
-# type 'a abs
-# type t16 = A : 'a abs -> t16 [@@unboxed]
-# type t18 = A : 'a list abs -> t18 [@@unboxed]
-# * Characters 176-256:
+type t11 = L of float [@@unboxed]
+- : unit = ()
+type 'a t12 = M of 'a t12 [@@unboxed]
+val f : int t12 array -> int t12 = <fun>
+type t13 = A : 'a t12 -> t13 [@@unboxed]
+type t14
+type t15 = A of t14 [@@unboxed]
+type 'a abs
+type t16 = A : 'a abs -> t16 [@@unboxed]
+type t18 = A : 'a list abs -> t18 [@@unboxed]
+Characters 176-256:
......struct
type t = A of float [@@ocaml.unboxed]
type u = { f1 : t; f2 : t }
type u = { f1 : t; f2 : t; }
Their internal representations differ:
the first declaration uses unboxed float representation.
-# * * module T : sig type t [@@immediate] end
-# * type 'a s = S : 'a -> 'a s [@@unboxed]
-# type t = T : 'a s -> t [@@unboxed]
-# type 'a s = S : 'a -> 'a option s [@@unboxed]
-# type t = T : 'a s -> t [@@unboxed]
-# module M :
+module T : sig type t [@@immediate] end
+type 'a s = S : 'a -> 'a s [@@unboxed]
+type t = T : 'a s -> t [@@unboxed]
+type 'a s = S : 'a -> 'a option s [@@unboxed]
+type t = T : 'a s -> t [@@unboxed]
+module M :
sig type 'a r constraint 'a = unit -> 'b val inj : 'b -> (unit -> 'b) r end
-# type t = T : (unit -> 'a) M.r -> t [@@unboxed]
-# type 'a s = S : (unit -> 'a) M.r -> 'a option s [@@unboxed]
-# type t = T : 'a s -> t [@@unboxed]
-# type 'a t = T : 'a s -> 'a t [@@unboxed]
-# type _ s = S : 'a t -> 'b s [@@unboxed]
+type t = T : (unit -> 'a) M.r -> t [@@unboxed]
+type 'a s = S : (unit -> 'a) M.r -> 'a option s [@@unboxed]
+type t = T : 'a s -> t [@@unboxed]
+type 'a t = T : 'a s -> 'a t [@@unboxed]
+type _ s = S : 'a t -> 'b s [@@unboxed]
and _ t = T : 'a -> 'a s t
-# type 'a s
+type 'a s
type ('a, 'p) t = private 'a s
type 'a packed = T : ('a, 'b) t -> 'a packed [@@unboxed]
-#
+type f = { field : 'a. 'a list; } [@@unboxed]
+val g : f array =
+ [|{field = []}; {field = []}; {field = []}; {field = []}; {field = []};
+ {field = []}; {field = []}; {field = []}; {field = []}; {field = []}|]
+val h : f = {field = []}
+type 'a t [@@immediate]
+type u = U : 'a t -> u [@@unboxed]
+
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
+(* TEST
+ * toplevel
+*)
external a : (int [@untagged]) -> unit = "a" "a_nat"
external b : (int32 [@unboxed]) -> unit = "b" "b_nat"
+++ /dev/null
-
-# external a : (int [@untagged]) -> unit = "a" "a_nat"
-external b : (int32 [@unboxed]) -> unit = "b" "b_nat"
-external c : (int64 [@unboxed]) -> unit = "c" "c_nat"
-external d : (nativeint [@unboxed]) -> unit = "d" "d_nat"
-external e : (float [@unboxed]) -> unit = "e" "e_nat"
-type t = private int
-external f : (t [@untagged]) -> unit = "f" "f_nat"
-module M :
- sig
- external a : int -> (int [@untagged]) = "a" "a_nat"
- external b : (int [@untagged]) -> int = "b" "b_nat"
- end
-# Characters 382-451:
- external f : (int32 [@unboxed]) -> (int32 [@unboxed]) = "f" "noalloc"
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
-# Characters 63-122:
- external a : float -> float = "a" "noalloc" "a_nat" "float"
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 3: deprecated: [@@unboxed] + [@@noalloc] should be used instead of "float"
-Characters 125-176:
- external b : float -> float = "b" "noalloc" "b_nat"
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 3: deprecated: [@@noalloc] should be used instead of "noalloc"
-Characters 179-228:
- external c : float -> float = "c" "c_nat" "float"
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 3: deprecated: [@@unboxed] + [@@noalloc] should be used instead of "float"
-Characters 231-274:
- external d : float -> float = "d" "noalloc"
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 3: deprecated: [@@noalloc] should be used instead of "noalloc"
-Characters 441-505:
- ......struct
- external f : int -> (int [@untagged]) = "f" "f_nat"
- end..
-Error: Signature mismatch:
- Modules do not match:
- sig external f : int -> (int [@untagged]) = "f" "f_nat" end
- is not included in
- sig external f : int -> int = "f" "f_nat" end
- Values do not match:
- external f : int -> (int [@untagged]) = "f" "f_nat"
- is not included in
- external f : int -> int = "f" "f_nat"
-# Characters 65-129:
- ......struct
- external f : (int [@untagged]) -> int = "f" "f_nat"
- end..
-Error: Signature mismatch:
- Modules do not match:
- sig external f : (int [@untagged]) -> int = "f" "f_nat" end
- is not included in
- sig external f : int -> int = "a" "a_nat" end
- Values do not match:
- external f : (int [@untagged]) -> int = "f" "f_nat"
- is not included in
- external f : int -> int = "a" "a_nat"
-# Characters 69-136:
- ......struct
- external f : float -> (float [@unboxed]) = "f" "f_nat"
- end..
-Error: Signature mismatch:
- Modules do not match:
- sig external f : float -> (float [@unboxed]) = "f" "f_nat" end
- is not included in
- sig external f : float -> float = "f" "f_nat" end
- Values do not match:
- external f : float -> (float [@unboxed]) = "f" "f_nat"
- is not included in
- external f : float -> float = "f" "f_nat"
-# Characters 69-136:
- ......struct
- external f : (float [@unboxed]) -> float = "f" "f_nat"
- end..
-Error: Signature mismatch:
- Modules do not match:
- sig external f : (float [@unboxed]) -> float = "f" "f_nat" end
- is not included in
- sig external f : float -> float = "a" "a_nat" end
- Values do not match:
- external f : (float [@unboxed]) -> float = "f" "f_nat"
- is not included in
- external f : float -> float = "a" "a_nat"
-# Characters 149-199:
- ......struct
- external f : int -> int = "f" "f_nat"
- end..
-Error: Signature mismatch:
- Modules do not match:
- sig external f : int -> int = "f" "f_nat" end
- is not included in
- sig external f : int -> (int [@untagged]) = "f" "f_nat" end
- Values do not match:
- external f : int -> int = "f" "f_nat"
- is not included in
- external f : int -> (int [@untagged]) = "f" "f_nat"
-# Characters 79-129:
- ......struct
- external f : int -> int = "a" "a_nat"
- end..
-Error: Signature mismatch:
- Modules do not match:
- sig external f : int -> int = "a" "a_nat" end
- is not included in
- sig external f : (int [@untagged]) -> int = "f" "f_nat" end
- Values do not match:
- external f : int -> int = "a" "a_nat"
- is not included in
- external f : (int [@untagged]) -> int = "f" "f_nat"
-# Characters 82-136:
- ......struct
- external f : float -> float = "f" "f_nat"
- end..
-Error: Signature mismatch:
- Modules do not match:
- sig external f : float -> float = "f" "f_nat" end
- is not included in
- sig external f : float -> (float [@unboxed]) = "f" "f_nat" end
- Values do not match:
- external f : float -> float = "f" "f_nat"
- is not included in
- external f : float -> (float [@unboxed]) = "f" "f_nat"
-# Characters 82-136:
- ......struct
- external f : float -> float = "a" "a_nat"
- end..
-Error: Signature mismatch:
- Modules do not match:
- sig external f : float -> float = "a" "a_nat" end
- is not included in
- sig external f : (float [@unboxed]) -> float = "f" "f_nat" end
- Values do not match:
- external f : float -> float = "a" "a_nat"
- is not included in
- external f : (float [@unboxed]) -> float = "f" "f_nat"
-# Characters 67-72:
- external g : (float [@untagged]) -> float = "g" "g_nat";;
- ^^^^^
-Error: Don't know how to untag this type. Only int can be untagged
-# Characters 14-17:
- external h : (int [@unboxed]) -> float = "h" "h_nat";;
- ^^^
-Error: Don't know how to unbox this type. Only float, int32, int64 and nativeint can be unboxed
-# Characters 52-64:
- external i : int -> float [@unboxed] = "i" "i_nat";;
- ^^^^^^^^^^^^
-Error: Don't know how to unbox this type. Only float, int32, int64 and nativeint can be unboxed
-# Characters 61-66:
- external j : int -> (float [@unboxed]) * float = "j" "j_nat";;
- ^^^^^
-Error: The attribute '@unboxed' should be attached to a direct argument or result of the primitive, it should not occur deeply into its type
-# * external k : int -> float = "k" "k_nat"
-# Characters 58-119:
- external l : float -> float = "l" "l_nat" "float" [@@unboxed];;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Cannot use "float" in conjunction with [@unboxed]/[@untagged]
-# Characters 0-62:
- external m : (float [@unboxed]) -> float = "m" "m_nat" "float";;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Cannot use "float" in conjunction with [@unboxed]/[@untagged]
-# Characters 0-55:
- external n : float -> float = "n" "noalloc" [@@noalloc];;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Cannot use "noalloc" in conjunction with [@@noalloc]
-# Characters 70-115:
- external o : (float[@unboxed]) -> float = "o";;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
-# Characters 0-45:
- external p : float -> (float[@unboxed]) = "p";;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
-# Characters 0-44:
- external q : (int[@untagged]) -> float = "q";;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
-# Characters 0-42:
- external r : int -> (int[@untagged]) = "r";;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
-# Characters 0-42:
- external s : int -> int = "s" [@@untagged];;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
-# Characters 0-45:
- external t : float -> float = "t" [@@unboxed];;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
-# type 'a b = B of 'a b b [@@unboxed]
-#
--- /dev/null
+external a : (int [@untagged]) -> unit = "a" "a_nat"
+external b : (int32 [@unboxed]) -> unit = "b" "b_nat"
+external c : (int64 [@unboxed]) -> unit = "c" "c_nat"
+external d : (nativeint [@unboxed]) -> unit = "d" "d_nat"
+external e : (float [@unboxed]) -> unit = "e" "e_nat"
+type t = private int
+external f : (t [@untagged]) -> unit = "f" "f_nat"
+module M :
+ sig
+ external a : int -> (int [@untagged]) = "a" "a_nat"
+ external b : (int [@untagged]) -> int = "b" "b_nat"
+ end
+Characters 382-451:
+ external f : (int32 [@unboxed]) -> (int32 [@unboxed]) = "f" "noalloc"
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+Characters 63-122:
+ external a : float -> float = "a" "noalloc" "a_nat" "float"
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 3: deprecated: [@@unboxed] + [@@noalloc] should be used instead of "float"
+Characters 125-176:
+ external b : float -> float = "b" "noalloc" "b_nat"
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 3: deprecated: [@@noalloc] should be used instead of "noalloc"
+Characters 179-228:
+ external c : float -> float = "c" "c_nat" "float"
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 3: deprecated: [@@unboxed] + [@@noalloc] should be used instead of "float"
+Characters 231-274:
+ external d : float -> float = "d" "noalloc"
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 3: deprecated: [@@noalloc] should be used instead of "noalloc"
+Characters 441-505:
+ ......struct
+ external f : int -> (int [@untagged]) = "f" "f_nat"
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig external f : int -> (int [@untagged]) = "f" "f_nat" end
+ is not included in
+ sig external f : int -> int = "f" "f_nat" end
+ Values do not match:
+ external f : int -> (int [@untagged]) = "f" "f_nat"
+ is not included in
+ external f : int -> int = "f" "f_nat"
+Characters 65-129:
+ ......struct
+ external f : (int [@untagged]) -> int = "f" "f_nat"
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig external f : (int [@untagged]) -> int = "f" "f_nat" end
+ is not included in
+ sig external f : int -> int = "a" "a_nat" end
+ Values do not match:
+ external f : (int [@untagged]) -> int = "f" "f_nat"
+ is not included in
+ external f : int -> int = "a" "a_nat"
+Characters 69-136:
+ ......struct
+ external f : float -> (float [@unboxed]) = "f" "f_nat"
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig external f : float -> (float [@unboxed]) = "f" "f_nat" end
+ is not included in
+ sig external f : float -> float = "f" "f_nat" end
+ Values do not match:
+ external f : float -> (float [@unboxed]) = "f" "f_nat"
+ is not included in
+ external f : float -> float = "f" "f_nat"
+Characters 69-136:
+ ......struct
+ external f : (float [@unboxed]) -> float = "f" "f_nat"
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig external f : (float [@unboxed]) -> float = "f" "f_nat" end
+ is not included in
+ sig external f : float -> float = "a" "a_nat" end
+ Values do not match:
+ external f : (float [@unboxed]) -> float = "f" "f_nat"
+ is not included in
+ external f : float -> float = "a" "a_nat"
+Characters 149-199:
+ ......struct
+ external f : int -> int = "f" "f_nat"
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig external f : int -> int = "f" "f_nat" end
+ is not included in
+ sig external f : int -> (int [@untagged]) = "f" "f_nat" end
+ Values do not match:
+ external f : int -> int = "f" "f_nat"
+ is not included in
+ external f : int -> (int [@untagged]) = "f" "f_nat"
+Characters 79-129:
+ ......struct
+ external f : int -> int = "a" "a_nat"
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig external f : int -> int = "a" "a_nat" end
+ is not included in
+ sig external f : (int [@untagged]) -> int = "f" "f_nat" end
+ Values do not match:
+ external f : int -> int = "a" "a_nat"
+ is not included in
+ external f : (int [@untagged]) -> int = "f" "f_nat"
+Characters 82-136:
+ ......struct
+ external f : float -> float = "f" "f_nat"
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig external f : float -> float = "f" "f_nat" end
+ is not included in
+ sig external f : float -> (float [@unboxed]) = "f" "f_nat" end
+ Values do not match:
+ external f : float -> float = "f" "f_nat"
+ is not included in
+ external f : float -> (float [@unboxed]) = "f" "f_nat"
+Characters 82-136:
+ ......struct
+ external f : float -> float = "a" "a_nat"
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig external f : float -> float = "a" "a_nat" end
+ is not included in
+ sig external f : (float [@unboxed]) -> float = "f" "f_nat" end
+ Values do not match:
+ external f : float -> float = "a" "a_nat"
+ is not included in
+ external f : (float [@unboxed]) -> float = "f" "f_nat"
+Characters 67-72:
+ external g : (float [@untagged]) -> float = "g" "g_nat";;
+ ^^^^^
+Error: Don't know how to untag this type. Only int can be untagged
+Characters 14-17:
+ external h : (int [@unboxed]) -> float = "h" "h_nat";;
+ ^^^
+Error: Don't know how to unbox this type. Only float, int32, int64 and nativeint can be unboxed
+Characters 52-64:
+ external i : int -> float [@unboxed] = "i" "i_nat";;
+ ^^^^^^^^^^^^
+Error: Don't know how to unbox this type. Only float, int32, int64 and nativeint can be unboxed
+Characters 61-66:
+ external j : int -> (float [@unboxed]) * float = "j" "j_nat";;
+ ^^^^^
+Error: The attribute '@unboxed' should be attached to a direct argument or result of the primitive, it should not occur deeply into its type
+external k : int -> float = "k" "k_nat"
+Characters 58-119:
+ external l : float -> float = "l" "l_nat" "float" [@@unboxed];;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Cannot use "float" in conjunction with [@unboxed]/[@untagged]
+Characters 0-62:
+ external m : (float [@unboxed]) -> float = "m" "m_nat" "float";;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Cannot use "float" in conjunction with [@unboxed]/[@untagged]
+Characters 0-55:
+ external n : float -> float = "n" "noalloc" [@@noalloc];;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Cannot use "noalloc" in conjunction with [@@noalloc]
+Characters 70-115:
+ external o : (float[@unboxed]) -> float = "o";;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+Characters 0-45:
+ external p : float -> (float[@unboxed]) = "p";;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+Characters 0-44:
+ external q : (int[@untagged]) -> float = "q";;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+Characters 0-42:
+ external r : int -> (int[@untagged]) = "r";;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+Characters 0-42:
+ external s : int -> int = "s" [@@untagged];;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+Characters 0-45:
+ external t : float -> float = "t" [@@unboxed];;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+type 'a b = B of 'a b b [@@unboxed]
+
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
-include $(BASEDIR)/makefiles/Makefile.common
-TOPFLAGS = -w A -strict-sequence
--- /dev/null
+- : unit = ()
+
+<----------------------------------------------------------------------
+To check the result file for this test, it suffices to look for "val"
+lines corresponding to toplevel answers. If they start with
+
+ val ambiguous_...
+
+then just above there should be the warning text for Warning 57
+(we try to avoid all other warnings). If they start with
+
+ val not_ambiguous_...
+
+then just above there should be *no* warning text.
+---------------------------------------------------------------------->
+
+type expr = Val of int | Rest
+Characters 46-71:
+ | ((Val x, _) | (_, Val x)) when x < 0 -> ()
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 57: Ambiguous or-pattern variables under guard;
+variable x may match different arguments. (See manual section 9.5)
+val ambiguous_typical_example : expr * expr -> unit = <fun>
+Note that an Assert_failure is expected just below.
+Exception: Assert_failure ("//toplevel//", 30, 6).
+val not_ambiguous__no_orpat : int option -> unit = <fun>
+val not_ambiguous__no_guard : [< `A | `B | `C ] -> unit = <fun>
+val not_ambiguous__no_patvar_in_guard :
+ bool -> [> `B of 'a | `C of 'a ] -> unit = <fun>
+val not_ambiguous__disjoint_cases : [> `B of bool | `C of bool ] -> unit =
+ <fun>
+val not_ambiguous__prefix_variables :
+ [> `B of bool * 'a option * 'a option ] -> unit = <fun>
+Characters 33-72:
+ | (`B (x, _, Some y) | `B (x, Some y, _)) when y -> ignore x
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 57: Ambiguous or-pattern variables under guard;
+variable y may match different arguments. (See manual section 9.5)
+val ambiguous__y : [> `B of 'a * bool option * bool option ] -> unit = <fun>
+val not_ambiguous__rhs_not_protected :
+ [> `B of 'a * bool option * bool option ] -> unit = <fun>
+Characters 35-74:
+ | (`B (x, _, Some y) | `B (x, Some y, _)) when x < y -> ()
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 57: Ambiguous or-pattern variables under guard;
+variable y may match different arguments. (See manual section 9.5)
+val ambiguous__x_y : [> `B of 'a * 'a option * 'a option ] -> unit = <fun>
+Characters 37-76:
+ | (`B (x, z, Some y) | `B (x, Some y, z)) when x < y || Some x = z -> ()
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 57: Ambiguous or-pattern variables under guard;
+variables y,z may match different arguments. (See manual section 9.5)
+val ambiguous__x_y_z : [> `B of 'a * 'a option * 'a option ] -> unit = <fun>
+val not_ambiguous__disjoint_in_depth :
+ [> `A of [> `B of bool | `C of bool ] ] -> unit = <fun>
+val not_ambiguous__prefix_variables_in_depth :
+ [> `A of [> `B of bool * [> `C1 | `C2 ] ] ] -> unit = <fun>
+Characters 40-76:
+ | `A (`B (Some x, _) | `B (_, Some x)) when x -> ()
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 57: Ambiguous or-pattern variables under guard;
+variable x may match different arguments. (See manual section 9.5)
+val ambiguous__in_depth :
+ [> `A of [> `B of bool option * bool option ] ] -> unit = <fun>
+val not_ambiguous__several_orpats :
+ [> `A of
+ [> `B of 'a * 'b option * 'c option ] *
+ [> `C of 'a * 'd option * 'e option ] *
+ [> `D1 of 'f * 'a * 'g option * 'h | `D2 of 'i * 'a * 'j * 'k option ] ] ->
+ unit = <fun>
+Characters 43-140:
+ ....`A ((`B (Some x, _) | `B (_, Some x)),
+ (`C (Some y, Some _, _) | `C (Some y, _, Some _))).................
+Warning 57: Ambiguous or-pattern variables under guard;
+variable x may match different arguments. (See manual section 9.5)
+val ambiguous__first_orpat :
+ [> `A of
+ [> `B of 'a option * 'a option ] *
+ [> `C of 'a option * 'b option * 'c option ] ] ->
+ unit = <fun>
+Characters 44-141:
+ ....`A ((`B (Some x, Some _, _) | `B (Some x, _, Some _)),
+ (`C (Some y, _) | `C (_, Some y))).................
+Warning 57: Ambiguous or-pattern variables under guard;
+variable y may match different arguments. (See manual section 9.5)
+val ambiguous__second_orpat :
+ [> `A of
+ [> `B of 'a option * 'b option * 'c option ] *
+ [> `C of 'a option * 'a option ] ] ->
+ unit = <fun>
+val not_ambiguous__pairs : bool * 'a option * 'b option -> unit = <fun>
+val not_ambiguous__vars : bool -> unit = <fun>
+val not_ambiguous__as :
+ ('a list * 'b list -> bool) -> 'a list * 'b list -> unit = <fun>
+val not_ambiguous__as_var : ('a list * 'b -> bool) -> 'a list * 'b -> unit =
+ <fun>
+val not_ambiguous__var_as :
+ ('a list * 'b -> bool) -> ('a list * 'b) * 'c option * 'd option -> unit =
+ <fun>
+val not_ambiguous__lazy : ('a list * 'b list) * bool lazy_t -> unit = <fun>
+type t = A of int * int option * int option | B
+val not_ambiguous__constructor : t -> unit = <fun>
+type amoi = Z of int | Y of int * int | X of amoi * amoi
+Characters 40-73:
+ ..X (Z x,Y (y,0))
+ | X (Z y,Y (x,_))
+Warning 57: Ambiguous or-pattern variables under guard;
+variables x,y may match different arguments. (See manual section 9.5)
+val ambiguous__amoi : amoi -> int = <fun>
+module type S = sig val b : bool end
+Characters 56-101:
+ ....(module M:S),_,(1,_)
+ | _,(module M:S),(_,1)...................
+Warning 57: Ambiguous or-pattern variables under guard;
+variable M may match different arguments. (See manual section 9.5)
+val ambiguous__module_variable :
+ (module S) * (module S) * (int * int) -> bool -> int = <fun>
+val not_ambiguous__module_variable :
+ (module S) * (module S) * (int * int) -> bool -> int = <fun>
+type t2 = A of int * int | B of int * int
+Characters 55-56:
+ | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1
+ ^
+Warning 41: A belongs to several types: t2 t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 42-138:
+ .........................................function
+ | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1
+ | _ -> 2
+Warning 4: this pattern-matching is fragile.
+It will remain exhaustive when constructors are added to type t2.
+Characters 55-107:
+ | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 57: Ambiguous or-pattern variables under guard;
+variables x,y may match different arguments. (See manual section 9.5)
+val ambiguous_xy_but_not_ambiguous_z : (int -> int -> bool) -> t2 -> int =
+ <fun>
+val not_ambiguous__as_disjoint_on_second_column_split :
+ int option * int -> unit = <fun>
+no warning below
+val solved_ambiguity_typical_example : expr * expr -> unit = <fun>
+yet a warning below
+Characters 164-189:
+ | ((Val y, _) | (_, Val y)) when y < 0 -> ()
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 57: Ambiguous or-pattern variables under guard;
+variable y may match different arguments. (See manual section 9.5)
+val guarded_ambiguity : expr * expr -> unit = <fun>
+type a = A1 | A2
+type 'a alg = Val of 'a | Binop of 'a alg * 'a alg
+warning below
+Characters 100-125:
+ | ((Val x, _) | (_, Val x)) when pred x -> ()
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 57: Ambiguous or-pattern variables under guard;
+variable x may match different arguments. (See manual section 9.5)
+val cmp : (a -> bool) -> a alg -> a alg -> unit = <fun>
+type a = A1
+type 'a alg = Val of 'a | Binop of 'a alg * 'a alg
+no warning below
+val cmp : (a -> bool) -> a alg -> a alg -> unit = <fun>
+
+(* TEST
+ flags = " -w A -strict-sequence "
+ * toplevel
+*)
+
(* Ignore OCAMLRUNPARAM=b to be reproducible *)
Printexc.record_backtrace false;;
(* Mixed case *)
-type t = A of int * int | B of int * int
+type t2 = A of int * int | B of int * int
;;
let ambiguous_xy_but_not_ambiguous_z g = function
| A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1
| _ -> 2
;;
+
+(* Regression test against an erroneous simplification of the algorithm
+
+ One cannot compute the stable variable of the first row of a matrix
+ after its simplification and before splitting the
+ submatrices. Indeed, further splits on the submatrices may reveal
+ that some rows of this first column belong to disjoint submatrices,
+ and thus that the variables are more stable than is visible when
+ looking at the full column.
+*)
+let not_ambiguous__as_disjoint_on_second_column_split = function
+| ((Some a, (1 as b)) | (Some b, (2 as a))) when a = 0 -> ignore a; ignore b
+| _ -> ()
+;;
+
+let () = print_endline "no warning below";;
+(* we check for the ambiguous case first, so there
+ is no warning *)
+let solved_ambiguity_typical_example = function
+ | (Val x, Val y) ->
+ if x < 0 || y < 0
+ then ()
+ else ()
+ | ((Val x, _) | (_, Val x)) when x < 0 -> ()
+ | (_, Rest) -> ()
+ | (_, Val x) ->
+ (* the reader can expect *)
+ assert (x >= 0);
+ (* to hold here. *)
+ ()
+;;
+
+let () = print_endline "yet a warning below";;
+(* if the check for the ambiguous case is guarded,
+ there is still a warning *)
+let guarded_ambiguity = function
+ | (Val x, Val y) when x < 0 || y < 0 -> ()
+ | ((Val y, _) | (_, Val y)) when y < 0 -> ()
+ | (_, Rest) -> ()
+ | (_, Val x) ->
+ (* the reader can expect *)
+ assert (x >= 0);
+ (* to hold here. *)
+ ()
+;;
+
+(* see GPR#1552 *)
+type a = A1 | A2;;
+
+type 'a alg =
+ | Val of 'a
+ | Binop of 'a alg * 'a alg;;
+
+let () = print_endline "warning below";;
+let cmp (pred : a -> bool) (x : a alg) (y : a alg) =
+ match x, y with
+ | Val A1, Val A1 -> ()
+ | ((Val x, _) | (_, Val x)) when pred x -> ()
+ (* below: silence exhaustiveness/fragility warnings *)
+ | (Val (A1 | A2) | Binop _), _ -> ()
+;;
+
+type a = A1;;
+
+type 'a alg =
+ | Val of 'a
+ | Binop of 'a alg * 'a alg;;
+
+let () = print_endline "no warning below";;
+let cmp (pred : a -> bool) (x : a alg) (y : a alg) =
+ match x, y with
+ | Val A1, Val A1 -> ()
+ | ((Val x, _) | (_, Val x)) when pred x -> ()
+ (* below: silence exhaustiveness/fragility warnings *)
+ | (Val A1 | Binop _), _ -> ()
+;;
+++ /dev/null
-
-# - : unit = ()
-#
-<----------------------------------------------------------------------
-To check the result file for this test, it suffices to look for "val"
-lines corresponding to toplevel answers. If they start with
-
- val ambiguous_...
-
-then just above there should be the warning text for Warning 57
-(we try to avoid all other warnings). If they start with
-
- val not_ambiguous_...
-
-then just above there should be *no* warning text.
----------------------------------------------------------------------->
-
-# type expr = Val of int | Rest
-# Characters 46-71:
- | ((Val x, _) | (_, Val x)) when x < 0 -> ()
- ^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 57: Ambiguous or-pattern variables under guard;
-variable x may match different arguments. (See manual section 8.5)
-val ambiguous_typical_example : expr * expr -> unit = <fun>
-# Note that an Assert_failure is expected just below.
-# Exception: Assert_failure ("//toplevel//", 25, 6).
-# val not_ambiguous__no_orpat : int option -> unit = <fun>
-# val not_ambiguous__no_guard : [< `A | `B | `C ] -> unit = <fun>
-# val not_ambiguous__no_patvar_in_guard :
- bool -> [> `B of 'a | `C of 'a ] -> unit = <fun>
-# val not_ambiguous__disjoint_cases : [> `B of bool | `C of bool ] -> unit =
- <fun>
-# * * * val not_ambiguous__prefix_variables :
- [> `B of bool * 'a option * 'a option ] -> unit = <fun>
-# Characters 33-72:
- | (`B (x, _, Some y) | `B (x, Some y, _)) when y -> ignore x
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 57: Ambiguous or-pattern variables under guard;
-variable y may match different arguments. (See manual section 8.5)
-val ambiguous__y : [> `B of 'a * bool option * bool option ] -> unit = <fun>
-# * * * * * * * * val not_ambiguous__rhs_not_protected :
- [> `B of 'a * bool option * bool option ] -> unit = <fun>
-# Characters 35-74:
- | (`B (x, _, Some y) | `B (x, Some y, _)) when x < y -> ()
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 57: Ambiguous or-pattern variables under guard;
-variable y may match different arguments. (See manual section 8.5)
-val ambiguous__x_y : [> `B of 'a * 'a option * 'a option ] -> unit = <fun>
-# Characters 37-76:
- | (`B (x, z, Some y) | `B (x, Some y, z)) when x < y || Some x = z -> ()
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 57: Ambiguous or-pattern variables under guard;
-variables y,z may match different arguments. (See manual section 8.5)
-val ambiguous__x_y_z : [> `B of 'a * 'a option * 'a option ] -> unit = <fun>
-# val not_ambiguous__disjoint_in_depth :
- [> `A of [> `B of bool | `C of bool ] ] -> unit = <fun>
-# val not_ambiguous__prefix_variables_in_depth :
- [> `A of [> `B of bool * [> `C1 | `C2 ] ] ] -> unit = <fun>
-# Characters 40-76:
- | `A (`B (Some x, _) | `B (_, Some x)) when x -> ()
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 57: Ambiguous or-pattern variables under guard;
-variable x may match different arguments. (See manual section 8.5)
-val ambiguous__in_depth :
- [> `A of [> `B of bool option * bool option ] ] -> unit = <fun>
-# val not_ambiguous__several_orpats :
- [> `A of
- [> `B of 'a * 'b option * 'c option ] *
- [> `C of 'a * 'd option * 'e option ] *
- [> `D1 of 'f * 'a * 'g option * 'h | `D2 of 'i * 'a * 'j * 'k option ] ] ->
- unit = <fun>
-# Characters 43-140:
- ....`A ((`B (Some x, _) | `B (_, Some x)),
- (`C (Some y, Some _, _) | `C (Some y, _, Some _))).................
-Warning 57: Ambiguous or-pattern variables under guard;
-variable x may match different arguments. (See manual section 8.5)
-val ambiguous__first_orpat :
- [> `A of
- [> `B of 'a option * 'a option ] *
- [> `C of 'a option * 'b option * 'c option ] ] ->
- unit = <fun>
-# Characters 44-141:
- ....`A ((`B (Some x, Some _, _) | `B (Some x, _, Some _)),
- (`C (Some y, _) | `C (_, Some y))).................
-Warning 57: Ambiguous or-pattern variables under guard;
-variable y may match different arguments. (See manual section 8.5)
-val ambiguous__second_orpat :
- [> `A of
- [> `B of 'a option * 'b option * 'c option ] *
- [> `C of 'a option * 'a option ] ] ->
- unit = <fun>
-# val not_ambiguous__pairs : bool * 'a option * 'b option -> unit = <fun>
-# val not_ambiguous__vars : bool -> unit = <fun>
-# val not_ambiguous__as :
- ('a list * 'b list -> bool) -> 'a list * 'b list -> unit = <fun>
-# val not_ambiguous__as_var : ('a list * 'b -> bool) -> 'a list * 'b -> unit =
- <fun>
-# val not_ambiguous__var_as :
- ('a list * 'b -> bool) -> ('a list * 'b) * 'c option * 'd option -> unit =
- <fun>
-# val not_ambiguous__lazy : ('a list * 'b list) * bool lazy_t -> unit = <fun>
-# type t = A of int * int option * int option | B
-# val not_ambiguous__constructor : t -> unit = <fun>
-# type amoi = Z of int | Y of int * int | X of amoi * amoi
-# Characters 40-73:
- ..X (Z x,Y (y,0))
- | X (Z y,Y (x,_))
-Warning 57: Ambiguous or-pattern variables under guard;
-variables x,y may match different arguments. (See manual section 8.5)
-val ambiguous__amoi : amoi -> int = <fun>
-# module type S = sig val b : bool end
-# Characters 56-101:
- ....(module M:S),_,(1,_)
- | _,(module M:S),(_,1)...................
-Warning 57: Ambiguous or-pattern variables under guard;
-variable M may match different arguments. (See manual section 8.5)
-val ambiguous__module_variable :
- (module S) * (module S) * (int * int) -> bool -> int = <fun>
-# val not_ambiguous__module_variable :
- (module S) * (module S) * (int * int) -> bool -> int = <fun>
-# type t = A of int * int | B of int * int
-# Characters 55-56:
- | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1
- ^
-Warning 41: A belongs to several types: t t
-The first one was selected. Please disambiguate if this is wrong.
-Characters 42-138:
- .........................................function
- | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1
- | _ -> 2
-Warning 4: this pattern-matching is fragile.
-It will remain exhaustive when constructors are added to type t.
-Characters 55-107:
- | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 57: Ambiguous or-pattern variables under guard;
-variables x,y may match different arguments. (See manual section 8.5)
-val ambiguous_xy_but_not_ambiguous_z : (int -> int -> bool) -> t -> int =
- <fun>
-#
--- /dev/null
+- : unit = ()
+Characters 16-19:
+ let _ = ignore (+);;
+ ^^^
+Warning 5: this function application is partial,
+maybe some arguments are missing.
+- : unit = ()
+Characters 19-20:
+ let _ = raise Exit 3;;
+ ^
+Warning 20: this argument will not be used by the function.
+Exception: Stdlib.Pervasives.Exit.
+
+(* TEST
+ flags = " -w A -strict-sequence "
+ * toplevel
+*)
+
(* Ignore OCAMLRUNPARAM=b to be reproducible *)
Printexc.record_backtrace false;;
+++ /dev/null
-
-# - : unit = ()
-# Characters 16-19:
- let _ = ignore (+);;
- ^^^
-Warning 5: this function application is partial,
-maybe some arguments are missing.
-- : unit = ()
-# Characters 19-20:
- let _ = raise Exit 3;;
- ^
-Warning 20: this argument will not be used by the function.
-Exception: Pervasives.Exit.
-#
--- /dev/null
+Characters 168-171:
+ fun b -> if b then format_of_string "x" else "y";;
+ ^^^
+Warning 18: this coercion to format6 is not principal.
+- : bool -> ('a, 'b, 'c, 'd, 'd, 'a) format6 = <fun>
+Characters 28-48:
+ fun b -> if b then "x" else format_of_string "y";;
+ ^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type
+ ('a, 'b, 'c, 'd, 'd, 'a) format6 =
+ ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6
+ but an expression was expected of type string
+- : bool -> ('a, 'b, 'a) format = <fun>
+module PR7135 :
+ sig
+ module M : sig type t = private int end
+ type t = M.t
+ val lift2 : (int -> int -> int) -> t -> t -> int
+ end
+Characters 133-143:
+ let f x = let y = if true then x else (x:t) in (y :> int)
+ ^^^^^^^^^^
+Warning 18: this ground coercion is not principal.
+module Test1 : sig type t = private int val f : t -> int end
+
--- /dev/null
+- : bool -> ('a, 'b, 'c, 'd, 'd, 'a) format6 = <fun>
+Characters 28-48:
+ fun b -> if b then "x" else format_of_string "y";;
+ ^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type
+ ('a, 'b, 'c, 'd, 'd, 'a) format6 =
+ ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6
+ but an expression was expected of type string
+- : bool -> ('a, 'b, 'a) format = <fun>
+module PR7135 :
+ sig
+ module M : sig type t = private int end
+ type t = M.t
+ val lift2 : (int -> int -> int) -> t -> t -> int
+ end
+module Test1 : sig type t = private int val f : t -> int end
+
+(* TEST
+ flags = " -w A -strict-sequence "
+ * toplevel
+ * toplevel with principal
+*)
+
(* comment 9644 of PR#6000 *)
fun b -> if b then format_of_string "x" else "y";;
+++ /dev/null
-
-# Characters 76-79:
- fun b -> if b then format_of_string "x" else "y";;
- ^^^
-Warning 18: this coercion to format6 is not principal.
-- : bool -> ('a, 'b, 'c, 'd, 'd, 'a) format6 = <fun>
-# Characters 28-48:
- fun b -> if b then "x" else format_of_string "y";;
- ^^^^^^^^^^^^^^^^^^^^
-Error: This expression has type
- ('a, 'b, 'c, 'd, 'd, 'a) format6 =
- ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6
- but an expression was expected of type string
-# - : bool -> ('a, 'b, 'a) format = <fun>
-# module PR7135 :
- sig
- module M : sig type t = private int end
- type t = M.t
- val lift2 : (int -> int -> int) -> t -> t -> int
- end
-# Characters 133-143:
- let f x = let y = if true then x else (x:t) in (y :> int)
- ^^^^^^^^^^
-Warning 18: this ground coercion is not principal.
-module Test1 : sig type t = private int val f : t -> int end
-#
+++ /dev/null
-
-# - : bool -> ('a, 'b, 'c, 'd, 'd, 'a) format6 = <fun>
-# Characters 28-48:
- fun b -> if b then "x" else format_of_string "y";;
- ^^^^^^^^^^^^^^^^^^^^
-Error: This expression has type
- ('a, 'b, 'c, 'd, 'd, 'a) format6 =
- ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6
- but an expression was expected of type string
-# - : bool -> ('a, 'b, 'a) format = <fun>
-# module PR7135 :
- sig
- module M : sig type t = private int end
- type t = M.t
- val lift2 : (int -> int -> int) -> t -> t -> int
- end
-# module Test1 : sig type t = private int val f : t -> int end
-#
--- /dev/null
+Characters 121-173:
+ ........function
+ None, None -> 1
+ | Some _, Some _ -> 2..
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+((Some _, None)|(None, Some _))
+val f : 'a option * 'b option -> int = <fun>
+type _ t = A : int t | B : bool t | C : char t | D : float t
+type (_, _, _, _) u = U : (int, int, int, int) u
+type v = E | F | G
+Characters 124-205:
+ .function A, A, A, A, A, A, A, _, U, U -> 1
+ | _, _, _, _, _, _, _, G, _, _ -> 1
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(A, A, A, A, A, A, B, (E|F), _, _)
+Characters 172-200:
+ | _, _, _, _, _, _, _, G, _, _ -> 1
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 56: this match case is unreachable.
+Consider replacing it with a refutation case '<pat> -> .'
+val f :
+ 'a t * 'b t * 'c t * 'd t * 'e t * 'f t * 'g t * v * ('a, 'b, 'c, 'd) u *
+ ('e, 'f, 'g, 'g) u -> int = <fun>
+Characters 40-68:
+ let f (x : int t) = match x with A -> 1 | _ -> 2;; (* warn *)
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 4: this pattern-matching is fragile.
+It will remain exhaustive when constructors are added to type t.
+Characters 62-63:
+ let f (x : int t) = match x with A -> 1 | _ -> 2;; (* warn *)
+ ^
+Warning 56: this match case is unreachable.
+Consider replacing it with a refutation case '<pat> -> .'
+val f : int t -> int = <fun>
+Characters 53-54:
+ let f (x : unit t option) = match x with None -> 1 | _ -> 2 ;; (* warn? *)
+ ^
+Warning 56: this match case is unreachable.
+Consider replacing it with a refutation case '<pat> -> .'
+val f : unit t option -> int = <fun>
+Characters 53-59:
+ let f (x : unit t option) = match x with None -> 1 | Some _ -> 2 ;; (* warn *)
+ ^^^^^^
+Warning 56: this match case is unreachable.
+Consider replacing it with a refutation case '<pat> -> .'
+val f : unit t option -> int = <fun>
+val f : int t option -> int = <fun>
+Characters 27-49:
+ let f (x : int t option) = match x with None -> 1;; (* warn *)
+ ^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some A
+val f : int t option -> int = <fun>
+type 'a box = Box of 'a
+type 'a pair = { left : 'a; right : 'a; }
+Characters 50-69:
+ let f : (int t box pair * bool) option -> unit = function None -> ();;
+ ^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some ({left=Box A; right=Box A}, _)
+val f : (int t box pair * bool) option -> unit = <fun>
+val f : (string t box pair * bool) option -> unit = <fun>
+Characters 8-39:
+ let f = function {left=Box 0; _ } -> ();;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+{left=Box 1; _ }
+val f : int box pair -> unit = <fun>
+Characters 8-47:
+ let f = function {left=Box 0;right=Box 1} -> ();;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+{left=Box 0; right=Box 0}
+val f : int box pair -> unit = <fun>
+type _ t = Int : int t | Bool : bool t
+val f : 'a t -> 'a = <fun>
+val g : int t -> int = <fun>
+val h : 'a t -> 'a t -> bool = <fun>
+type (_, _) cmp = Eq : ('a, 'a) cmp | Any : ('a, 'b) cmp
+module A : sig type a type b val eq : (a, b) cmp end
+Characters 33-51:
+ let f : (A.a, A.b) cmp -> unit = function Any -> ()
+ ^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+val f : (A.a, A.b) cmp -> unit = <fun>
+val deep : char t option -> char = <fun>
+type zero = Zero
+type _ succ = Succ
+type (_, _, _) plus =
+ Plus0 : (zero, 'a, 'a) plus
+ | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus
+val trivial : (zero succ, zero, zero) plus option -> bool = <fun>
+val easy : (zero, zero succ, zero) plus option -> bool = <fun>
+Characters 71-93:
+ function None -> false
+ ^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some (PlusS _)
+val harder : (zero succ, zero succ, zero succ) plus option -> bool = <fun>
+val harder : (zero succ, zero succ, zero succ) plus option -> bool = <fun>
+val inv_zero : ('a, 'b, 'c) plus -> ('c, 'd, zero) plus -> bool = <fun>
+type _ t = Int : int t
+val f : bool t -> 'a = <fun>
+Characters 54-55:
+ let f () = match None with _ -> .;; (* error *)
+ ^
+Error: This match case could not be refuted.
+ Here is an example of a value that would reach it: _
+Characters 47-48:
+ let g () = match None with _ -> () | exception _ -> .;; (* error *)
+ ^
+Error: This match case could not be refuted.
+ Here is an example of a value that would reach it: _
+Characters 27-28:
+ let h () = match None with _ -> . | exception _ -> .;; (* error *)
+ ^
+Error: This match case could not be refuted.
+ Here is an example of a value that would reach it: _
+val f : 'a option -> unit = <fun>
+Characters 47-77:
+ let f x y = match 1 with 1 when x = y -> 1;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+All clauses in this pattern-matching are guarded.
+val f : 'a -> 'a -> int = <fun>
+Characters 62-91:
+ let f = function {contents=_}, 0 -> 0;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(_, 1)
+val f : 'a ref * int -> int = <fun>
+Characters 68-148:
+ ........function
+ | None -> ()
+ | Some x when x > 0 -> ()
+ | Some x when x <= 0 -> ()
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some _
+(However, some guarded clause may match this value.)
+val f : int option -> unit = <fun>
+
+(* TEST
+ flags = " -w A -strict-sequence "
+ * toplevel
+*)
+
(* Warn about all relevant cases when possible *)
let f = function
None, None -> 1
(* #7504, Example with no constraints on a record *)
let f = function {contents=_}, 0 -> 0;;
+
+(* inexhaustive however some guarded clause might match *)
+let f = function
+ | None -> ()
+ | Some x when x > 0 -> ()
+ | Some x when x <= 0 -> ()
+;;
+++ /dev/null
-
-# Characters 58-110:
- ........function
- None, None -> 1
- | Some _, Some _ -> 2..
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-((Some _, None)|(None, Some _))
-val f : 'a option * 'b option -> int = <fun>
-# type _ t = A : int t | B : bool t | C : char t | D : float t
-type (_, _, _, _) u = U : (int, int, int, int) u
-type v = E | F | G
-# Characters 124-205:
- .function A, A, A, A, A, A, A, _, U, U -> 1
- | _, _, _, _, _, _, _, G, _, _ -> 1
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-(A, A, A, A, A, A, B, (E|F), _, _)
-Characters 172-200:
- | _, _, _, _, _, _, _, G, _, _ -> 1
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 56: this match case is unreachable.
-Consider replacing it with a refutation case '<pat> -> .'
-val f :
- 'a t * 'b t * 'c t * 'd t * 'e t * 'f t * 'g t * v * ('a, 'b, 'c, 'd) u *
- ('e, 'f, 'g, 'g) u -> int = <fun>
-# Characters 40-68:
- let f (x : int t) = match x with A -> 1 | _ -> 2;; (* warn *)
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 4: this pattern-matching is fragile.
-It will remain exhaustive when constructors are added to type t.
-Characters 62-63:
- let f (x : int t) = match x with A -> 1 | _ -> 2;; (* warn *)
- ^
-Warning 56: this match case is unreachable.
-Consider replacing it with a refutation case '<pat> -> .'
-val f : int t -> int = <fun>
-# Characters 53-54:
- let f (x : unit t option) = match x with None -> 1 | _ -> 2 ;; (* warn? *)
- ^
-Warning 56: this match case is unreachable.
-Consider replacing it with a refutation case '<pat> -> .'
-val f : unit t option -> int = <fun>
-# Characters 53-59:
- let f (x : unit t option) = match x with None -> 1 | Some _ -> 2 ;; (* warn *)
- ^^^^^^
-Warning 56: this match case is unreachable.
-Consider replacing it with a refutation case '<pat> -> .'
-val f : unit t option -> int = <fun>
-# val f : int t option -> int = <fun>
-# Characters 27-49:
- let f (x : int t option) = match x with None -> 1;; (* warn *)
- ^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-Some A
-val f : int t option -> int = <fun>
-# type 'a box = Box of 'a
-type 'a pair = { left : 'a; right : 'a; }
-# Characters 50-69:
- let f : (int t box pair * bool) option -> unit = function None -> ();;
- ^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-Some ({left=Box A; right=Box A}, _)
-val f : (int t box pair * bool) option -> unit = <fun>
-# val f : (string t box pair * bool) option -> unit = <fun>
-# Characters 8-39:
- let f = function {left=Box 0; _ } -> ();;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-{left=Box 1; _ }
-val f : int box pair -> unit = <fun>
-# Characters 8-47:
- let f = function {left=Box 0;right=Box 1} -> ();;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-{left=Box 0; right=Box 0}
-val f : int box pair -> unit = <fun>
-# type _ t = Int : int t | Bool : bool t
-# val f : 'a t -> 'a = <fun>
-# val g : int t -> int = <fun>
-# val h : 'a t -> 'a t -> bool = <fun>
-# type (_, _) cmp = Eq : ('a, 'a) cmp | Any : ('a, 'b) cmp
-module A : sig type a type b val eq : (a, b) cmp end
-# Characters 33-51:
- let f : (A.a, A.b) cmp -> unit = function Any -> ()
- ^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-Eq
-val f : (A.a, A.b) cmp -> unit = <fun>
-# val deep : char t option -> char = <fun>
-# type zero = Zero
-type _ succ = Succ
-# type (_, _, _) plus =
- Plus0 : (zero, 'a, 'a) plus
- | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus
-# val trivial : (zero succ, zero, zero) plus option -> bool = <fun>
-# val easy : (zero, zero succ, zero) plus option -> bool = <fun>
-# Characters 71-93:
- function None -> false
- ^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-Some (PlusS _)
-val harder : (zero succ, zero succ, zero succ) plus option -> bool = <fun>
-# val harder : (zero succ, zero succ, zero succ) plus option -> bool = <fun>
-# val inv_zero : ('a, 'b, 'c) plus -> ('c, 'd, zero) plus -> bool = <fun>
-# type _ t = Int : int t
-# val f : bool t -> 'a = <fun>
-# Characters 54-55:
- let f () = match None with _ -> .;; (* error *)
- ^
-Error: This match case could not be refuted.
- Here is an example of a value that would reach it: _
-# Characters 47-48:
- let g () = match None with _ -> () | exception _ -> .;; (* error *)
- ^
-Error: This match case could not be refuted.
- Here is an example of a value that would reach it: _
-# Characters 27-28:
- let h () = match None with _ -> . | exception _ -> .;; (* error *)
- ^
-Error: This match case could not be refuted.
- Here is an example of a value that would reach it: _
-# val f : 'a option -> unit = <fun>
-# Characters 47-77:
- let f x y = match 1 with 1 when x = y -> 1;;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-All clauses in this pattern-matching are guarded.
-val f : 'a -> 'a -> int = <fun>
-# Characters 62-91:
- let f = function {contents=_}, 0 -> 0;;
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-(_, 1)
-val f : 'a ref * int -> int = <fun>
-#
--- /dev/null
+ambiguous_guarded_disjunction.ml
+application.ml
+coercions.ml
+exhaustiveness.ml
+pr5892.ml
+pr6587.ml
+pr6872.ml
+pr7085.ml
+pr7115.ml
+pr7261.ml
+pr7297.ml
+pr7553.ml
+records.ml
+unused_types.ml
--- /dev/null
+type _ choice =
+ Left : CamlinternalOO.label choice
+ | Right : CamlinternalOO.tag choice
+Characters 31-52:
+ let f : label choice -> bool = function Left -> true;; (* warn *)
+ ^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Right
+val f : CamlinternalOO.label choice -> bool = <fun>
+
+(* TEST
+ flags = " -w A -strict-sequence "
+ * toplevel
+*)
+
open CamlinternalOO;;
type _ choice = Left : label choice | Right : tag choice;;
let f : label choice -> bool = function Left -> true;; (* warn *)
+++ /dev/null
-
-# # type _ choice =
- Left : CamlinternalOO.label choice
- | Right : CamlinternalOO.tag choice
-# Characters 31-52:
- let f : label choice -> bool = function Left -> true;; (* warn *)
- ^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-Right
-val f : CamlinternalOO.label choice -> bool = <fun>
-#
--- /dev/null
+module A : sig val f : fpclass -> fpclass end
+type fpclass = A
+Characters 49-85:
+ ..struct
+ let f A = FP_normal
+ end
+Error: Signature mismatch:
+ Modules do not match:
+ sig val f : fpclass -> Stdlib.fpclass end
+ is not included in
+ sig val f : fpclass -> fpclass end
+ Values do not match:
+ val f : fpclass -> Stdlib.fpclass
+ is not included in
+ val f : fpclass -> fpclass
+
+(* TEST
+ flags = " -w A -strict-sequence "
+ * toplevel
+*)
+
module A: sig val f: fpclass -> fpclass end =
struct
+++ /dev/null
-
-# module A : sig val f : fpclass -> fpclass end
-# type fpclass = A
-# Characters 49-85:
- ..struct
- let f A = FP_normal
- end
-Error: Signature mismatch:
- Modules do not match:
- sig val f : fpclass -> Pervasives.fpclass end
- is not included in
- sig val f : fpclass -> fpclass end
- Values do not match:
- val f : fpclass -> Pervasives.fpclass
- is not included in
- val f : fpclass -> fpclass
-#
--- /dev/null
+- : unit = ()
+exception A
+type a = A
+Characters 1-2:
+ A;;
+ ^
+Warning 41: A belongs to several types: a exn
+The first one was selected. Please disambiguate if this is wrong.
+- : a = A
+Characters 6-7:
+ raise A;;
+ ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Exception: A.
+- : a -> unit = <fun>
+Characters 26-27:
+ function Not_found -> 1 | A -> 2 | _ -> 3;;
+ ^
+Warning 41: A belongs to several types: a exn
+The first one was selected. Please disambiguate if this is wrong.
+Characters 26-27:
+ function Not_found -> 1 | A -> 2 | _ -> 3;;
+ ^
+Error: This pattern matches values of type a
+ but a pattern was expected which matches values of type exn
+Characters 10-11:
+ try raise A with A -> 2;;
+ ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 17-18:
+ try raise A with A -> 2;;
+ ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+- : int = 2
+
--- /dev/null
+- : unit = ()
+exception A
+type a = A
+Characters 1-2:
+ A;;
+ ^
+Warning 41: A belongs to several types: a exn
+The first one was selected. Please disambiguate if this is wrong.
+- : a = A
+Characters 6-7:
+ raise A;;
+ ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Exception: A.
+- : a -> unit = <fun>
+Characters 26-27:
+ function Not_found -> 1 | A -> 2 | _ -> 3;;
+ ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+- : exn -> int = <fun>
+Characters 10-11:
+ try raise A with A -> 2;;
+ ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 17-18:
+ try raise A with A -> 2;;
+ ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+- : int = 2
+
+(* TEST
+ flags = " -w A -strict-sequence "
+ * toplevel
+ * toplevel with principal
+*)
+
(* Ignore OCAMLRUNPARAM=b to be reproducible *)
Printexc.record_backtrace false;;
+++ /dev/null
-
-# - : unit = ()
-# exception A
-# type a = A
-# Characters 1-2:
- A;;
- ^
-Warning 41: A belongs to several types: a exn
-The first one was selected. Please disambiguate if this is wrong.
-- : a = A
-# Characters 6-7:
- raise A;;
- ^
-Warning 42: this use of A relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Exception: A.
-# - : a -> unit = <fun>
-# Characters 26-27:
- function Not_found -> 1 | A -> 2 | _ -> 3;;
- ^
-Warning 41: A belongs to several types: a exn
-The first one was selected. Please disambiguate if this is wrong.
-Characters 26-27:
- function Not_found -> 1 | A -> 2 | _ -> 3;;
- ^
-Error: This pattern matches values of type a
- but a pattern was expected which matches values of type exn
-# Characters 10-11:
- try raise A with A -> 2;;
- ^
-Warning 42: this use of A relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 17-18:
- try raise A with A -> 2;;
- ^
-Warning 42: this use of A relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-- : int = 2
-#
+++ /dev/null
-
-# - : unit = ()
-# exception A
-# type a = A
-# Characters 1-2:
- A;;
- ^
-Warning 41: A belongs to several types: a exn
-The first one was selected. Please disambiguate if this is wrong.
-- : a = A
-# Characters 6-7:
- raise A;;
- ^
-Warning 42: this use of A relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Exception: A.
-# - : a -> unit = <fun>
-# Characters 26-27:
- function Not_found -> 1 | A -> 2 | _ -> 3;;
- ^
-Warning 42: this use of A relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-- : exn -> int = <fun>
-# Characters 10-11:
- try raise A with A -> 2;;
- ^
-Warning 42: this use of A relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 17-18:
- try raise A with A -> 2;;
- ^
-Warning 42: this use of A relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-- : int = 2
-#
--- /dev/null
+Characters 355-385:
+ match M.is_t () with None -> 0
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some (Is Eq)
+module TypEq : sig type (_, _) t = Eq : ('a, 'a) t end
+module type T =
+ sig
+ type _ is_t = Is : ('a, 'b) TypEq.t -> 'a is_t
+ val is_t : unit -> unit is_t option
+ end
+module Make : functor (M : T) -> sig val f : unit -> int end
+Characters 89-90:
+ let g : t -> int = function _ -> .
+ ^
+Error: This match case could not be refuted.
+ Here is an example of a value that would reach it: T (Is Eq)
+
+(* TEST
+ flags = " -w A -strict-sequence "
+ * toplevel
+*)
+
module TypEq = struct
type (_, _) t = Eq : ('a, 'a) t
end
+++ /dev/null
-
-# Characters 292-322:
- match M.is_t () with None -> 0
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-Some (Is Eq)
-module TypEq : sig type (_, _) t = Eq : ('a, 'a) t end
-module type T =
- sig
- type _ is_t = Is : ('a, 'b) TypEq.t -> 'a is_t
- val is_t : unit -> unit is_t option
- end
-module Make : functor (M : T) -> sig val f : unit -> int end
-# Characters 89-90:
- let g : t -> int = function _ -> .
- ^
-Error: This match case could not be refuted.
- Here is an example of a value that would reach it: T (Is Eq)
-#
--- /dev/null
+type t = A : t
+Characters 40-41:
+ let _f ~x (* x unused argument *) = function
+ ^
+Warning 27: unused variable x.
+module X1 : sig end
+Characters 36-37:
+ let x = 42 (* unused value *)
+ ^
+Warning 32: unused value x.
+module X2 : sig end
+Characters 54-55:
+ module O = struct let x = 42 (* unused *) end
+ ^
+Warning 32: unused value x.
+Characters 80-86:
+ open O (* unused open *)
+ ^^^^^^
+Warning 33: unused open O.
+module X3 : sig end
+
+(* TEST
+ flags = " -w A -strict-sequence "
+ * toplevel
+*)
+
type t = A : t;;
module X1 : sig end = struct
+++ /dev/null
-
-# type t = A : t
-# Characters 40-41:
- let _f ~x (* x unused argument *) = function
- ^
-Warning 27: unused variable x.
-module X1 : sig end
-# Characters 36-37:
- let x = 42 (* unused value *)
- ^
-Warning 32: unused value x.
-module X2 : sig end
-# Characters 54-55:
- module O = struct let x = 42 (* unused *) end
- ^
-Warning 32: unused value x.
-Characters 80-86:
- open O (* unused open *)
- ^^^^^^
-Warning 33: unused open O.
-module X3 : sig end
-#
--- /dev/null
+Characters 93-95:
+ Foo: [> `Bla ] as 'b ) * 'b -> foo;;
+ ^^
+Error: Syntax error
+Characters 46-60:
+ Foo: 'b * 'b -> foo constraint 'b = [> `Bla ];;
+ ^^^^^^^^^^^^^^
+Warning 62: Type constraints do not apply to GADT cases of variant types.
+type foo = Foo : 'b * 'b -> foo
+
+(* TEST
+ flags = " -w A -strict-sequence "
+ * toplevel
+*)
+
type foo =
Foo: [> `Bla ] as 'b ) * 'b -> foo;;
type foo =
+++ /dev/null
-
-# Characters 30-32:
- Foo: [> `Bla ] as 'b ) * 'b -> foo;;
- ^^
-Error: Syntax error
-# Characters 46-60:
- Foo: 'b * 'b -> foo constraint 'b = [> `Bla ];;
- ^^^^^^^^^^^^^^
-Warning 62: Type constraints do not apply to GADT cases of variant types.
-type foo = Foo : 'b * 'b -> foo
-#
--- /dev/null
+- : unit = ()
+Characters 10-20:
+ let () = raise Exit; () ;; (* warn *)
+ ^^^^^^^^^^
+Warning 21: this statement never returns (or has an unsound type.)
+Exception: Stdlib.Pervasives.Exit.
+
+(* TEST
+ flags = " -w A -strict-sequence "
+ * toplevel
+*)
+
(* Ignore OCAMLRUNPARAM=b to be reproducible *)
Printexc.record_backtrace false;;
+++ /dev/null
-
-# - : unit = ()
-# Characters 10-20:
- let () = raise Exit; () ;; (* warn *)
- ^^^^^^^^^^
-Warning 21: this statement never returns (or has an unsound type.)
-Exception: Pervasives.Exit.
-#
--- /dev/null
+module A : sig type foo end
+module rec B : sig type bar = Bar of A.foo end
+Characters 22-28:
+ open A
+ ^^^^^^
+Warning 33: unused open A.
+module rec C : sig end
+Characters 110-114:
+ let None = None
+ ^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some _
+Characters 93-99:
+ open A
+ ^^^^^^
+Warning 33: unused open A.
+module rec D : sig module M : sig module X : sig end end end
+
+(* TEST
+ flags = " -w A -strict-sequence "
+ * toplevel
+*)
+
module A = struct type foo end;;
module rec B : sig
+++ /dev/null
-
-# module A : sig type foo end
-# module rec B : sig type bar = Bar of A.foo end
-# Characters 22-28:
- open A
- ^^^^^^
-Warning 33: unused open A.
-module rec C : sig end
-# Characters 110-114:
- let None = None
- ^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-Some _
-Characters 93-99:
- open A
- ^^^^^^
-Warning 33: unused open A.
-module rec D : sig module M : sig module X : sig end end end
-#
--- /dev/null
+module M1 :
+ sig type t = { x : int; y : int; } type u = { x : bool; y : bool; } end
+Characters 49-50:
+ let f1 (r:t) = r.x (* ok *)
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 89-90:
+ let f2 r = ignore (r:t); r.x (* non principal *)
+ ^
+Warning 18: this type-based field disambiguation is not principal.
+Characters 89-90:
+ let f2 r = ignore (r:t); r.x (* non principal *)
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 148-149:
+ match r with {x; y} -> y + y (* ok *)
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 151-152:
+ match r with {x; y} -> y + y (* ok *)
+ ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 148-149:
+ match r with {x; y} -> y + y (* ok *)
+ ^
+Warning 27: unused variable x.
+module OK :
+ sig val f1 : M1.t -> int val f2 : M1.t -> int val f3 : M1.t -> int end
+Characters 55-61:
+ let f r = match r with {x; y} -> y + y
+ ^^^^^^
+Warning 41: these field labels belong to several types: M1.u M1.t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 65-66:
+ let f r = match r with {x; y} -> y + y
+ ^
+Error: This expression has type bool but an expression was expected of type
+ int
+Characters 85-91:
+ {x; y} -> y + y
+ ^^^^^^
+Warning 41: these field labels belong to several types: M1.u M1.t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 85-91:
+ {x; y} -> y + y
+ ^^^^^^
+Error: This pattern matches values of type M1.u
+ but a pattern was expected which matches values of type M1.t
+module M : sig type t = { x : int; } type u = { x : bool; } end
+Characters 18-21:
+ let f (r:M.t) = r.M.x;; (* ok *)
+ ^^^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+val f : M.t -> int = <fun>
+Characters 18-19:
+ let f (r:M.t) = r.x;; (* warning *)
+ ^
+Warning 40: x was selected from type M.t.
+It is not visible in the current scope, and will not
+be selected if the type becomes unknown.
+Characters 18-19:
+ let f (r:M.t) = r.x;; (* warning *)
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+val f : M.t -> int = <fun>
+Characters 8-9:
+ let f ({x}:M.t) = x;; (* warning *)
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 7-10:
+ let f ({x}:M.t) = x;; (* warning *)
+ ^^^
+Warning 40: this record of type M.t contains fields that are
+not visible in the current scope: x.
+They will not be selected if the type becomes unknown.
+val f : M.t -> int = <fun>
+module M : sig type t = { x : int; y : int; } end
+module N : sig type u = { x : bool; y : bool; } end
+Characters 57-58:
+ let f (r:M.t) = r.x
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 30-36:
+ open N
+ ^^^^^^
+Warning 33: unused open N.
+module OK : sig val f : M.t -> int end
+module M :
+ sig
+ type t = { x : int; }
+ module N : sig type s = t = { x : int; } end
+ type u = { x : bool; }
+ end
+module OK : sig val f : M.t -> int end
+module M :
+ sig
+ type u = { x : bool; y : int; z : char; }
+ type t = { x : int; y : bool; }
+ end
+Characters 37-38:
+ let f {x;z} = x,z
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 36-41:
+ let f {x;z} = x,z
+ ^^^^^
+Warning 9: the following labels are not bound in this record pattern:
+y
+Either bind these labels explicitly or add '; _' to the pattern.
+module OK : sig val f : M.u -> bool * char end
+Characters 38-52:
+ let r = {x=true;z='z'}
+ ^^^^^^^^^^^^^^
+Error: Some record fields are undefined: y
+Characters 90-91:
+ let r = {x=3; y=true}
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 95-96:
+ let r = {x=3; y=true}
+ ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+module OK :
+ sig
+ type u = { x : int; y : bool; }
+ type t = { x : bool; y : int; z : char; }
+ val r : u
+ end
+Characters 111-112:
+ let b : bar = {x=3; y=4}
+ ^
+Error: This record expression is expected to have type bar
+ The field y does not belong to type bar
+module M : sig type foo = { x : int; y : int; } end
+module N : sig type bar = { x : int; y : int; } end
+Characters 19-22:
+ let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+ ^^^
+Error: The record field N.y belongs to the type N.bar
+ but is mixed here with fields of type M.foo
+module MN :
+ sig
+ type foo = M.foo = { x : int; y : int; }
+ type bar = N.bar = { x : int; y : int; }
+ end
+module NM :
+ sig
+ type bar = N.bar = { x : int; y : int; }
+ type foo = M.foo = { x : int; y : int; }
+ end
+Characters 8-28:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^^^^^^^^^^^^^^^^^
+Warning 41: x belongs to several types: MN.bar MN.foo
+The first one was selected. Please disambiguate if this is wrong.
+Characters 8-28:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^^^^^^^^^^^^^^^^^
+Warning 41: y belongs to several types: NM.foo NM.bar
+The first one was selected. Please disambiguate if this is wrong.
+Characters 19-23:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^
+Error: The record field NM.y belongs to the type NM.foo = M.foo
+ but is mixed here with fields of type MN.bar = N.bar
+module M :
+ sig
+ type foo = { x : int; y : int; }
+ type bar = { x : int; y : int; z : int; }
+ end
+Characters 65-66:
+ let f r = ignore (r: foo); {r with x = 2; z = 3}
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 72-73:
+ let f r = ignore (r: foo); {r with x = 2; z = 3}
+ ^
+Error: This record expression is expected to have type M.foo
+ The field z does not belong to type M.foo
+module M :
+ sig
+ type foo = M.foo = { x : int; y : int; }
+ type bar = M.bar = { x : int; y : int; z : int; }
+ type other = { a : int; b : int; }
+ end
+Characters 66-67:
+ let f r = ignore (r: foo); { r with x = 3; a = 4 }
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 73-74:
+ let f r = ignore (r: foo); { r with x = 3; a = 4 }
+ ^
+Error: This record expression is expected to have type M.foo
+ The field a does not belong to type M.foo
+Characters 39-40:
+ let r = {x=1; y=2}
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 44-45:
+ let r = {x=1; y=2}
+ ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 67-68:
+ let r: other = {x=1; y=2}
+ ^
+Error: This record expression is expected to have type M.other
+ The field x does not belong to type M.other
+module A : sig type t = { x : int; } end
+module B : sig type t = { x : int; } end
+Characters 20-23:
+ let f (r : B.t) = r.A.x;; (* fail *)
+ ^^^
+Error: The field A.x belongs to the record type A.t
+ but a field was expected belonging to the record type B.t
+Characters 88-91:
+ let a : t = {x=1;yyz=2}
+ ^^^
+Error: This record expression is expected to have type t
+ The field yyz does not belong to type t
+Hint: Did you mean yyy?
+type t = A
+type s = A
+class f : t -> object end
+Characters 12-13:
+ class g = f A;; (* ok *)
+ ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+class g : f
+class f : 'a -> 'a -> object end
+Characters 13-14:
+ class g = f (A : t) A;; (* warn with -principal *)
+ ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 20-21:
+ class g = f (A : t) A;; (* warn with -principal *)
+ ^
+Warning 18: this type-based constructor disambiguation is not principal.
+Characters 20-21:
+ class g = f (A : t) A;; (* warn with -principal *)
+ ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+class g : f
+Characters 199-200:
+ let y : t = {x = 0}
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 114-120:
+ open M (* this open is unused, it isn't reported as shadowing 'x' *)
+ ^^^^^^
+Warning 33: unused open M.
+module Shadow1 :
+ sig
+ type t = { x : int; }
+ module M : sig type s = { x : string; } end
+ val y : t
+ end
+Characters 97-103:
+ open M (* this open shadows label 'x' *)
+ ^^^^^^
+Warning 45: this open statement shadows the label x (which is later used)
+Characters 149-157:
+ let y = {x = ""}
+ ^^^^^^^^
+Warning 41: these field labels belong to several types: M.s t
+The first one was selected. Please disambiguate if this is wrong.
+module Shadow2 :
+ sig
+ type t = { x : int; }
+ module M : sig type s = { x : string; } end
+ val y : M.s
+ end
+Characters 167-170:
+ let f (u : u) = match u with `Key {loc} -> loc
+ ^^^
+Warning 42: this use of loc relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+module P6235 :
+ sig
+ type t = { loc : string; }
+ type v = { loc : string; x : int; }
+ type u = [ `Key of t ]
+ val f : u -> string
+ end
+Characters 219-224:
+ |`Key {loc} -> loc
+ ^^^^^
+Warning 41: these field labels belong to several types: v t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 219-224:
+ |`Key {loc} -> loc
+ ^^^^^
+Warning 9: the following labels are not bound in this record pattern:
+x
+Either bind these labels explicitly or add '; _' to the pattern.
+Characters 214-224:
+ |`Key {loc} -> loc
+ ^^^^^^^^^^
+Error: This pattern matches values of type [? `Key of v ]
+ but a pattern was expected which matches values of type u
+ Types for tag `Key are incompatible
+
--- /dev/null
+module M1 :
+ sig type t = { x : int; y : int; } type u = { x : bool; y : bool; } end
+Characters 49-50:
+ let f1 (r:t) = r.x (* ok *)
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 89-90:
+ let f2 r = ignore (r:t); r.x (* non principal *)
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 148-149:
+ match r with {x; y} -> y + y (* ok *)
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 151-152:
+ match r with {x; y} -> y + y (* ok *)
+ ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 148-149:
+ match r with {x; y} -> y + y (* ok *)
+ ^
+Warning 27: unused variable x.
+module OK :
+ sig val f1 : M1.t -> int val f2 : M1.t -> int val f3 : M1.t -> int end
+Characters 55-61:
+ let f r = match r with {x; y} -> y + y
+ ^^^^^^
+Warning 41: these field labels belong to several types: M1.u M1.t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 65-66:
+ let f r = match r with {x; y} -> y + y
+ ^
+Error: This expression has type bool but an expression was expected of type
+ int
+Characters 86-87:
+ {x; y} -> y + y
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 89-90:
+ {x; y} -> y + y
+ ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 86-87:
+ {x; y} -> y + y
+ ^
+Warning 27: unused variable x.
+module F2 : sig val f : M1.t -> int end
+module M : sig type t = { x : int; } type u = { x : bool; } end
+Characters 18-21:
+ let f (r:M.t) = r.M.x;; (* ok *)
+ ^^^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+val f : M.t -> int = <fun>
+Characters 18-19:
+ let f (r:M.t) = r.x;; (* warning *)
+ ^
+Warning 40: x was selected from type M.t.
+It is not visible in the current scope, and will not
+be selected if the type becomes unknown.
+Characters 18-19:
+ let f (r:M.t) = r.x;; (* warning *)
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+val f : M.t -> int = <fun>
+Characters 8-9:
+ let f ({x}:M.t) = x;; (* warning *)
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 7-10:
+ let f ({x}:M.t) = x;; (* warning *)
+ ^^^
+Warning 40: this record of type M.t contains fields that are
+not visible in the current scope: x.
+They will not be selected if the type becomes unknown.
+val f : M.t -> int = <fun>
+module M : sig type t = { x : int; y : int; } end
+module N : sig type u = { x : bool; y : bool; } end
+Characters 57-58:
+ let f (r:M.t) = r.x
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 30-36:
+ open N
+ ^^^^^^
+Warning 33: unused open N.
+module OK : sig val f : M.t -> int end
+module M :
+ sig
+ type t = { x : int; }
+ module N : sig type s = t = { x : int; } end
+ type u = { x : bool; }
+ end
+module OK : sig val f : M.t -> int end
+module M :
+ sig
+ type u = { x : bool; y : int; z : char; }
+ type t = { x : int; y : bool; }
+ end
+Characters 37-38:
+ let f {x;z} = x,z
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 36-41:
+ let f {x;z} = x,z
+ ^^^^^
+Warning 9: the following labels are not bound in this record pattern:
+y
+Either bind these labels explicitly or add '; _' to the pattern.
+module OK : sig val f : M.u -> bool * char end
+Characters 38-52:
+ let r = {x=true;z='z'}
+ ^^^^^^^^^^^^^^
+Error: Some record fields are undefined: y
+Characters 90-91:
+ let r = {x=3; y=true}
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 95-96:
+ let r = {x=3; y=true}
+ ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+module OK :
+ sig
+ type u = { x : int; y : bool; }
+ type t = { x : bool; y : int; z : char; }
+ val r : u
+ end
+Characters 111-112:
+ let b : bar = {x=3; y=4}
+ ^
+Error: This record expression is expected to have type bar
+ The field y does not belong to type bar
+module M : sig type foo = { x : int; y : int; } end
+module N : sig type bar = { x : int; y : int; } end
+Characters 19-22:
+ let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+ ^^^
+Error: The record field N.y belongs to the type N.bar
+ but is mixed here with fields of type M.foo
+module MN :
+ sig
+ type foo = M.foo = { x : int; y : int; }
+ type bar = N.bar = { x : int; y : int; }
+ end
+module NM :
+ sig
+ type bar = N.bar = { x : int; y : int; }
+ type foo = M.foo = { x : int; y : int; }
+ end
+Characters 8-28:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^^^^^^^^^^^^^^^^^
+Warning 41: x belongs to several types: MN.bar MN.foo
+The first one was selected. Please disambiguate if this is wrong.
+Characters 8-28:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^^^^^^^^^^^^^^^^^
+Warning 41: y belongs to several types: NM.foo NM.bar
+The first one was selected. Please disambiguate if this is wrong.
+Characters 19-23:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^
+Error: The record field NM.y belongs to the type NM.foo = M.foo
+ but is mixed here with fields of type MN.bar = N.bar
+module M :
+ sig
+ type foo = { x : int; y : int; }
+ type bar = { x : int; y : int; z : int; }
+ end
+Characters 65-66:
+ let f r = ignore (r: foo); {r with x = 2; z = 3}
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 72-73:
+ let f r = ignore (r: foo); {r with x = 2; z = 3}
+ ^
+Error: This record expression is expected to have type M.foo
+ The field z does not belong to type M.foo
+module M :
+ sig
+ type foo = M.foo = { x : int; y : int; }
+ type bar = M.bar = { x : int; y : int; z : int; }
+ type other = { a : int; b : int; }
+ end
+Characters 66-67:
+ let f r = ignore (r: foo); { r with x = 3; a = 4 }
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 73-74:
+ let f r = ignore (r: foo); { r with x = 3; a = 4 }
+ ^
+Error: This record expression is expected to have type M.foo
+ The field a does not belong to type M.foo
+Characters 39-40:
+ let r = {x=1; y=2}
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 44-45:
+ let r = {x=1; y=2}
+ ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 67-68:
+ let r: other = {x=1; y=2}
+ ^
+Error: This record expression is expected to have type M.other
+ The field x does not belong to type M.other
+module A : sig type t = { x : int; } end
+module B : sig type t = { x : int; } end
+Characters 20-23:
+ let f (r : B.t) = r.A.x;; (* fail *)
+ ^^^
+Error: The field A.x belongs to the record type A.t
+ but a field was expected belonging to the record type B.t
+Characters 88-91:
+ let a : t = {x=1;yyz=2}
+ ^^^
+Error: This record expression is expected to have type t
+ The field yyz does not belong to type t
+Hint: Did you mean yyy?
+type t = A
+type s = A
+class f : t -> object end
+Characters 12-13:
+ class g = f A;; (* ok *)
+ ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+class g : f
+class f : 'a -> 'a -> object end
+Characters 13-14:
+ class g = f (A : t) A;; (* warn with -principal *)
+ ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 20-21:
+ class g = f (A : t) A;; (* warn with -principal *)
+ ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+class g : f
+Characters 199-200:
+ let y : t = {x = 0}
+ ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 114-120:
+ open M (* this open is unused, it isn't reported as shadowing 'x' *)
+ ^^^^^^
+Warning 33: unused open M.
+module Shadow1 :
+ sig
+ type t = { x : int; }
+ module M : sig type s = { x : string; } end
+ val y : t
+ end
+Characters 97-103:
+ open M (* this open shadows label 'x' *)
+ ^^^^^^
+Warning 45: this open statement shadows the label x (which is later used)
+Characters 149-157:
+ let y = {x = ""}
+ ^^^^^^^^
+Warning 41: these field labels belong to several types: M.s t
+The first one was selected. Please disambiguate if this is wrong.
+module Shadow2 :
+ sig
+ type t = { x : int; }
+ module M : sig type s = { x : string; } end
+ val y : M.s
+ end
+Characters 167-170:
+ let f (u : u) = match u with `Key {loc} -> loc
+ ^^^
+Warning 42: this use of loc relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+module P6235 :
+ sig
+ type t = { loc : string; }
+ type v = { loc : string; x : int; }
+ type u = [ `Key of t ]
+ val f : u -> string
+ end
+Characters 220-223:
+ |`Key {loc} -> loc
+ ^^^
+Warning 42: this use of loc relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+module P6235' :
+ sig
+ type t = { loc : string; }
+ type v = { loc : string; x : int; }
+ type u = [ `Key of t ]
+ val f : u -> string
+ end
+
+(* TEST
+ flags = " -w A -strict-sequence "
+ * toplevel
+ * toplevel with principal
+*)
+
(* Use type information *)
module M1 = struct
type t = {x: int; y: int}
+++ /dev/null
-
-# module M1 :
- sig type t = { x : int; y : int; } type u = { x : bool; y : bool; } end
-# Characters 49-50:
- let f1 (r:t) = r.x (* ok *)
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 89-90:
- let f2 r = ignore (r:t); r.x (* non principal *)
- ^
-Warning 18: this type-based field disambiguation is not principal.
-Characters 89-90:
- let f2 r = ignore (r:t); r.x (* non principal *)
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 148-149:
- match r with {x; y} -> y + y (* ok *)
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 151-152:
- match r with {x; y} -> y + y (* ok *)
- ^
-Warning 42: this use of y relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 148-149:
- match r with {x; y} -> y + y (* ok *)
- ^
-Warning 27: unused variable x.
-module OK :
- sig val f1 : M1.t -> int val f2 : M1.t -> int val f3 : M1.t -> int end
-# Characters 55-61:
- let f r = match r with {x; y} -> y + y
- ^^^^^^
-Warning 41: these field labels belong to several types: M1.u M1.t
-The first one was selected. Please disambiguate if this is wrong.
-Characters 65-66:
- let f r = match r with {x; y} -> y + y
- ^
-Error: This expression has type bool but an expression was expected of type
- int
-# Characters 85-91:
- {x; y} -> y + y
- ^^^^^^
-Warning 41: these field labels belong to several types: M1.u M1.t
-The first one was selected. Please disambiguate if this is wrong.
-Characters 85-91:
- {x; y} -> y + y
- ^^^^^^
-Error: This pattern matches values of type M1.u
- but a pattern was expected which matches values of type M1.t
-# module M : sig type t = { x : int; } type u = { x : bool; } end
-# Characters 18-21:
- let f (r:M.t) = r.M.x;; (* ok *)
- ^^^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-val f : M.t -> int = <fun>
-# Characters 18-19:
- let f (r:M.t) = r.x;; (* warning *)
- ^
-Warning 40: x was selected from type M.t.
-It is not visible in the current scope, and will not
-be selected if the type becomes unknown.
-Characters 18-19:
- let f (r:M.t) = r.x;; (* warning *)
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-val f : M.t -> int = <fun>
-# Characters 8-9:
- let f ({x}:M.t) = x;; (* warning *)
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 7-10:
- let f ({x}:M.t) = x;; (* warning *)
- ^^^
-Warning 40: this record of type M.t contains fields that are
-not visible in the current scope: x.
-They will not be selected if the type becomes unknown.
-val f : M.t -> int = <fun>
-# module M : sig type t = { x : int; y : int; } end
-# module N : sig type u = { x : bool; y : bool; } end
-# Characters 57-58:
- let f (r:M.t) = r.x
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 30-36:
- open N
- ^^^^^^
-Warning 33: unused open N.
-module OK : sig val f : M.t -> int end
-# module M :
- sig
- type t = { x : int; }
- module N : sig type s = t = { x : int; } end
- type u = { x : bool; }
- end
-# module OK : sig val f : M.t -> int end
-# module M :
- sig
- type u = { x : bool; y : int; z : char; }
- type t = { x : int; y : bool; }
- end
-# Characters 37-38:
- let f {x;z} = x,z
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 36-41:
- let f {x;z} = x,z
- ^^^^^
-Warning 9: the following labels are not bound in this record pattern:
-y
-Either bind these labels explicitly or add '; _' to the pattern.
-module OK : sig val f : M.u -> bool * char end
-# Characters 38-52:
- let r = {x=true;z='z'}
- ^^^^^^^^^^^^^^
-Error: Some record fields are undefined: y
-# Characters 90-91:
- let r = {x=3; y=true}
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 95-96:
- let r = {x=3; y=true}
- ^
-Warning 42: this use of y relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-module OK :
- sig
- type u = { x : int; y : bool; }
- type t = { x : bool; y : int; z : char; }
- val r : u
- end
-# Characters 111-112:
- let b : bar = {x=3; y=4}
- ^
-Error: This record expression is expected to have type bar
- The field y does not belong to type bar
-# module M : sig type foo = { x : int; y : int; } end
-# module N : sig type bar = { x : int; y : int; } end
-# Characters 19-22:
- let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
- ^^^
-Error: The record field N.y belongs to the type N.bar
- but is mixed here with fields of type M.foo
-# module MN :
- sig
- type foo = M.foo = { x : int; y : int; }
- type bar = N.bar = { x : int; y : int; }
- end
-module NM :
- sig
- type bar = N.bar = { x : int; y : int; }
- type foo = M.foo = { x : int; y : int; }
- end
-# Characters 8-28:
- let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
- ^^^^^^^^^^^^^^^^^^^^
-Warning 41: x belongs to several types: MN.bar MN.foo
-The first one was selected. Please disambiguate if this is wrong.
-Characters 8-28:
- let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
- ^^^^^^^^^^^^^^^^^^^^
-Warning 41: y belongs to several types: NM.foo NM.bar
-The first one was selected. Please disambiguate if this is wrong.
-Characters 19-23:
- let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
- ^^^^
-Error: The record field NM.y belongs to the type NM.foo = M.foo
- but is mixed here with fields of type MN.bar = N.bar
-# module M :
- sig
- type foo = { x : int; y : int; }
- type bar = { x : int; y : int; z : int; }
- end
-# Characters 65-66:
- let f r = ignore (r: foo); {r with x = 2; z = 3}
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 72-73:
- let f r = ignore (r: foo); {r with x = 2; z = 3}
- ^
-Error: This record expression is expected to have type M.foo
- The field z does not belong to type M.foo
-# module M :
- sig
- type foo = M.foo = { x : int; y : int; }
- type bar = M.bar = { x : int; y : int; z : int; }
- type other = { a : int; b : int; }
- end
-# Characters 66-67:
- let f r = ignore (r: foo); { r with x = 3; a = 4 }
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 73-74:
- let f r = ignore (r: foo); { r with x = 3; a = 4 }
- ^
-Error: This record expression is expected to have type M.foo
- The field a does not belong to type M.foo
-# Characters 39-40:
- let r = {x=1; y=2}
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 44-45:
- let r = {x=1; y=2}
- ^
-Warning 42: this use of y relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 67-68:
- let r: other = {x=1; y=2}
- ^
-Error: This record expression is expected to have type M.other
- The field x does not belong to type M.other
-# module A : sig type t = { x : int; } end
-module B : sig type t = { x : int; } end
-# Characters 20-23:
- let f (r : B.t) = r.A.x;; (* fail *)
- ^^^
-Error: The field A.x belongs to the record type A.t
- but a field was expected belonging to the record type B.t
-# Characters 88-91:
- let a : t = {x=1;yyz=2}
- ^^^
-Error: This record expression is expected to have type t
- The field yyz does not belong to type t
-Hint: Did you mean yyy?
-# type t = A
-type s = A
-class f : t -> object end
-# Characters 12-13:
- class g = f A;; (* ok *)
- ^
-Warning 42: this use of A relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-class g : f
-# class f : 'a -> 'a -> object end
-# Characters 13-14:
- class g = f (A : t) A;; (* warn with -principal *)
- ^
-Warning 42: this use of A relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 20-21:
- class g = f (A : t) A;; (* warn with -principal *)
- ^
-Warning 18: this type-based constructor disambiguation is not principal.
-Characters 20-21:
- class g = f (A : t) A;; (* warn with -principal *)
- ^
-Warning 42: this use of A relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-class g : f
-# Characters 199-200:
- let y : t = {x = 0}
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 114-120:
- open M (* this open is unused, it isn't reported as shadowing 'x' *)
- ^^^^^^
-Warning 33: unused open M.
-module Shadow1 :
- sig
- type t = { x : int; }
- module M : sig type s = { x : string; } end
- val y : t
- end
-# Characters 97-103:
- open M (* this open shadows label 'x' *)
- ^^^^^^
-Warning 45: this open statement shadows the label x (which is later used)
-Characters 149-157:
- let y = {x = ""}
- ^^^^^^^^
-Warning 41: these field labels belong to several types: M.s t
-The first one was selected. Please disambiguate if this is wrong.
-module Shadow2 :
- sig
- type t = { x : int; }
- module M : sig type s = { x : string; } end
- val y : M.s
- end
-# Characters 167-170:
- let f (u : u) = match u with `Key {loc} -> loc
- ^^^
-Warning 42: this use of loc relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-module P6235 :
- sig
- type t = { loc : string; }
- type v = { loc : string; x : int; }
- type u = [ `Key of t ]
- val f : u -> string
- end
-# Characters 219-224:
- |`Key {loc} -> loc
- ^^^^^
-Warning 41: these field labels belong to several types: v t
-The first one was selected. Please disambiguate if this is wrong.
-Characters 219-224:
- |`Key {loc} -> loc
- ^^^^^
-Warning 9: the following labels are not bound in this record pattern:
-x
-Either bind these labels explicitly or add '; _' to the pattern.
-Characters 214-224:
- |`Key {loc} -> loc
- ^^^^^^^^^^
-Error: This pattern matches values of type [? `Key of v ]
- but a pattern was expected which matches values of type u
- Types for tag `Key are incompatible
-#
+++ /dev/null
-
-# module M1 :
- sig type t = { x : int; y : int; } type u = { x : bool; y : bool; } end
-# Characters 49-50:
- let f1 (r:t) = r.x (* ok *)
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 89-90:
- let f2 r = ignore (r:t); r.x (* non principal *)
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 148-149:
- match r with {x; y} -> y + y (* ok *)
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 151-152:
- match r with {x; y} -> y + y (* ok *)
- ^
-Warning 42: this use of y relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 148-149:
- match r with {x; y} -> y + y (* ok *)
- ^
-Warning 27: unused variable x.
-module OK :
- sig val f1 : M1.t -> int val f2 : M1.t -> int val f3 : M1.t -> int end
-# Characters 55-61:
- let f r = match r with {x; y} -> y + y
- ^^^^^^
-Warning 41: these field labels belong to several types: M1.u M1.t
-The first one was selected. Please disambiguate if this is wrong.
-Characters 65-66:
- let f r = match r with {x; y} -> y + y
- ^
-Error: This expression has type bool but an expression was expected of type
- int
-# Characters 86-87:
- {x; y} -> y + y
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 89-90:
- {x; y} -> y + y
- ^
-Warning 42: this use of y relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 86-87:
- {x; y} -> y + y
- ^
-Warning 27: unused variable x.
-module F2 : sig val f : M1.t -> int end
-# module M : sig type t = { x : int; } type u = { x : bool; } end
-# Characters 18-21:
- let f (r:M.t) = r.M.x;; (* ok *)
- ^^^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-val f : M.t -> int = <fun>
-# Characters 18-19:
- let f (r:M.t) = r.x;; (* warning *)
- ^
-Warning 40: x was selected from type M.t.
-It is not visible in the current scope, and will not
-be selected if the type becomes unknown.
-Characters 18-19:
- let f (r:M.t) = r.x;; (* warning *)
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-val f : M.t -> int = <fun>
-# Characters 8-9:
- let f ({x}:M.t) = x;; (* warning *)
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 7-10:
- let f ({x}:M.t) = x;; (* warning *)
- ^^^
-Warning 40: this record of type M.t contains fields that are
-not visible in the current scope: x.
-They will not be selected if the type becomes unknown.
-val f : M.t -> int = <fun>
-# module M : sig type t = { x : int; y : int; } end
-# module N : sig type u = { x : bool; y : bool; } end
-# Characters 57-58:
- let f (r:M.t) = r.x
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 30-36:
- open N
- ^^^^^^
-Warning 33: unused open N.
-module OK : sig val f : M.t -> int end
-# module M :
- sig
- type t = { x : int; }
- module N : sig type s = t = { x : int; } end
- type u = { x : bool; }
- end
-# module OK : sig val f : M.t -> int end
-# module M :
- sig
- type u = { x : bool; y : int; z : char; }
- type t = { x : int; y : bool; }
- end
-# Characters 37-38:
- let f {x;z} = x,z
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 36-41:
- let f {x;z} = x,z
- ^^^^^
-Warning 9: the following labels are not bound in this record pattern:
-y
-Either bind these labels explicitly or add '; _' to the pattern.
-module OK : sig val f : M.u -> bool * char end
-# Characters 38-52:
- let r = {x=true;z='z'}
- ^^^^^^^^^^^^^^
-Error: Some record fields are undefined: y
-# Characters 90-91:
- let r = {x=3; y=true}
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 95-96:
- let r = {x=3; y=true}
- ^
-Warning 42: this use of y relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-module OK :
- sig
- type u = { x : int; y : bool; }
- type t = { x : bool; y : int; z : char; }
- val r : u
- end
-# Characters 111-112:
- let b : bar = {x=3; y=4}
- ^
-Error: This record expression is expected to have type bar
- The field y does not belong to type bar
-# module M : sig type foo = { x : int; y : int; } end
-# module N : sig type bar = { x : int; y : int; } end
-# Characters 19-22:
- let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
- ^^^
-Error: The record field N.y belongs to the type N.bar
- but is mixed here with fields of type M.foo
-# module MN :
- sig
- type foo = M.foo = { x : int; y : int; }
- type bar = N.bar = { x : int; y : int; }
- end
-module NM :
- sig
- type bar = N.bar = { x : int; y : int; }
- type foo = M.foo = { x : int; y : int; }
- end
-# Characters 8-28:
- let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
- ^^^^^^^^^^^^^^^^^^^^
-Warning 41: x belongs to several types: MN.bar MN.foo
-The first one was selected. Please disambiguate if this is wrong.
-Characters 8-28:
- let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
- ^^^^^^^^^^^^^^^^^^^^
-Warning 41: y belongs to several types: NM.foo NM.bar
-The first one was selected. Please disambiguate if this is wrong.
-Characters 19-23:
- let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
- ^^^^
-Error: The record field NM.y belongs to the type NM.foo = M.foo
- but is mixed here with fields of type MN.bar = N.bar
-# module M :
- sig
- type foo = { x : int; y : int; }
- type bar = { x : int; y : int; z : int; }
- end
-# Characters 65-66:
- let f r = ignore (r: foo); {r with x = 2; z = 3}
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 72-73:
- let f r = ignore (r: foo); {r with x = 2; z = 3}
- ^
-Error: This record expression is expected to have type M.foo
- The field z does not belong to type M.foo
-# module M :
- sig
- type foo = M.foo = { x : int; y : int; }
- type bar = M.bar = { x : int; y : int; z : int; }
- type other = { a : int; b : int; }
- end
-# Characters 66-67:
- let f r = ignore (r: foo); { r with x = 3; a = 4 }
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 73-74:
- let f r = ignore (r: foo); { r with x = 3; a = 4 }
- ^
-Error: This record expression is expected to have type M.foo
- The field a does not belong to type M.foo
-# Characters 39-40:
- let r = {x=1; y=2}
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 44-45:
- let r = {x=1; y=2}
- ^
-Warning 42: this use of y relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 67-68:
- let r: other = {x=1; y=2}
- ^
-Error: This record expression is expected to have type M.other
- The field x does not belong to type M.other
-# module A : sig type t = { x : int; } end
-module B : sig type t = { x : int; } end
-# Characters 20-23:
- let f (r : B.t) = r.A.x;; (* fail *)
- ^^^
-Error: The field A.x belongs to the record type A.t
- but a field was expected belonging to the record type B.t
-# Characters 88-91:
- let a : t = {x=1;yyz=2}
- ^^^
-Error: This record expression is expected to have type t
- The field yyz does not belong to type t
-Hint: Did you mean yyy?
-# type t = A
-type s = A
-class f : t -> object end
-# Characters 12-13:
- class g = f A;; (* ok *)
- ^
-Warning 42: this use of A relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-class g : f
-# class f : 'a -> 'a -> object end
-# Characters 13-14:
- class g = f (A : t) A;; (* warn with -principal *)
- ^
-Warning 42: this use of A relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 20-21:
- class g = f (A : t) A;; (* warn with -principal *)
- ^
-Warning 42: this use of A relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-class g : f
-# Characters 199-200:
- let y : t = {x = 0}
- ^
-Warning 42: this use of x relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-Characters 114-120:
- open M (* this open is unused, it isn't reported as shadowing 'x' *)
- ^^^^^^
-Warning 33: unused open M.
-module Shadow1 :
- sig
- type t = { x : int; }
- module M : sig type s = { x : string; } end
- val y : t
- end
-# Characters 97-103:
- open M (* this open shadows label 'x' *)
- ^^^^^^
-Warning 45: this open statement shadows the label x (which is later used)
-Characters 149-157:
- let y = {x = ""}
- ^^^^^^^^
-Warning 41: these field labels belong to several types: M.s t
-The first one was selected. Please disambiguate if this is wrong.
-module Shadow2 :
- sig
- type t = { x : int; }
- module M : sig type s = { x : string; } end
- val y : M.s
- end
-# Characters 167-170:
- let f (u : u) = match u with `Key {loc} -> loc
- ^^^
-Warning 42: this use of loc relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-module P6235 :
- sig
- type t = { loc : string; }
- type v = { loc : string; x : int; }
- type u = [ `Key of t ]
- val f : u -> string
- end
-# Characters 220-223:
- |`Key {loc} -> loc
- ^^^
-Warning 42: this use of loc relies on type-directed disambiguation,
-it will not compile with OCaml 4.00 or earlier.
-module P6235' :
- sig
- type t = { loc : string; }
- type v = { loc : string; x : int; }
- type u = [ `Key of t ]
- val f : u -> string
- end
-#
--- /dev/null
+Characters 98-115:
+ type unused = int
+ ^^^^^^^^^^^^^^^^^
+Warning 34: unused type unused.
+module Unused : sig end
+Characters 68-93:
+ type nonrec unused = used
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 34: unused type unused.
+module Unused_nonrec : sig end
+Characters 40-65:
+ type unused = A of unused
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 34: unused type unused.
+Characters 40-65:
+ type unused = A of unused
+ ^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 37: unused constructor A.
+module Unused_rec : sig end
+Characters 46-70:
+ exception Nobody_uses_me
+ ^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 38: unused exception Nobody_uses_me
+module Unused_exception : sig end
+Characters 96-110:
+ type t += Nobody_uses_me
+ ^^^^^^^^^^^^^^
+Warning 38: unused extension constructor Nobody_uses_me
+module Unused_extension_constructor : sig type t = .. end
+Characters 91-121:
+ exception Nobody_constructs_me
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 38: exception Nobody_constructs_me is never used to build values.
+(However, this constructor appears in patterns.)
+module Unused_exception_outside_patterns : sig val falsity : exn -> bool end
+Characters 127-147:
+ type t += Nobody_constructs_me
+ ^^^^^^^^^^^^^^^^^^^^
+Warning 38: extension constructor Nobody_constructs_me is never used to build values.
+(However, this constructor appears in patterns.)
+module Unused_extension_outside_patterns :
+ sig type t = .. val falsity : t -> bool end
+Characters 88-109:
+ exception Private_exn
+ ^^^^^^^^^^^^^^^^^^^^^
+Warning 38: exception Private_exn is never used to build values.
+It is exported or rebound as a private extension.
+module Unused_private_exception : sig type exn += private Private_exn end
+Characters 124-135:
+ type t += Private_ext
+ ^^^^^^^^^^^
+Warning 38: extension constructor Private_ext is never used to build values.
+It is exported or rebound as a private extension.
+module Unused_private_extension :
+ sig type t = .. type t += private Private_ext end
+module Pr7438 : sig end
+
+(* TEST
+ flags = " -w A -strict-sequence "
+ * toplevel
+*)
+
module Unused : sig
end = struct
type unused = int
+++ /dev/null
-
-# Characters 35-52:
- type unused = int
- ^^^^^^^^^^^^^^^^^
-Warning 34: unused type unused.
-module Unused : sig end
-# Characters 68-93:
- type nonrec unused = used
- ^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 34: unused type unused.
-module Unused_nonrec : sig end
-# Characters 40-65:
- type unused = A of unused
- ^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 34: unused type unused.
-Characters 40-65:
- type unused = A of unused
- ^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 37: unused constructor A.
-module Unused_rec : sig end
-# Characters 46-70:
- exception Nobody_uses_me
- ^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 38: unused exception Nobody_uses_me
-module Unused_exception : sig end
-# Characters 96-110:
- type t += Nobody_uses_me
- ^^^^^^^^^^^^^^
-Warning 38: unused extension constructor Nobody_uses_me
-module Unused_extension_constructor : sig type t = .. end
-# Characters 91-121:
- exception Nobody_constructs_me
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 38: exception Nobody_constructs_me is never used to build values.
-(However, this constructor appears in patterns.)
-module Unused_exception_outside_patterns : sig val falsity : exn -> bool end
-# Characters 127-147:
- type t += Nobody_constructs_me
- ^^^^^^^^^^^^^^^^^^^^
-Warning 38: extension constructor Nobody_constructs_me is never used to build values.
-(However, this constructor appears in patterns.)
-module Unused_extension_outside_patterns :
- sig type t = .. val falsity : t -> bool end
-# Characters 88-109:
- exception Private_exn
- ^^^^^^^^^^^^^^^^^^^^^
-Warning 38: exception Private_exn is never used to build values.
-It is exported or rebound as a private extension.
-module Unused_private_exception : sig type exn += private Private_exn end
-# Characters 124-135:
- type t += Private_ext
- ^^^^^^^^^^^
-Warning 38: extension constructor Private_ext is never used to build values.
-It is exported or rebound as a private extension.
-module Unused_private_extension :
- sig type t = .. type t += private Private_ext end
-# module Pr7438 : sig end
-#
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Alain Frisch, LexiFi *
-#* *
-#* Copyright 2012 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-MODULES=testing misc identifiable numbers strongly_connected_components
-INCLUDES= -I $(OTOPDIR)/utils
-ADD_COMPFLAGS=$(INCLUDES)
-CMO_FILES+="misc.cmo"
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
-
-BYTECODE_ONLY=true
+(* TEST
+include config
+include testing
+binary_modules = "misc identifiable numbers"
+* bytecode
+*)
+
let edit_distance = Misc.edit_distance
let show_cutoff n =
--- /dev/null
+edit_distance.ml
+overflow_detection.ml
+test_strongly_connected_components.ml
--- /dev/null
+(* TEST
+include config
+include testing
+binary_modules = "misc identifiable numbers"
+* bytecode
+*)
+
+let print_int i =
+ if i = max_int then
+ "max_int"
+ else if i = min_int then
+ "min_int"
+ else
+ string_of_int i
+
+let test_no_overflow_add a b =
+ Printf.printf "Misc.no_overflow_add %s %s = %b\n"
+ (print_int a)
+ (print_int b)
+ (Misc.no_overflow_add a b)
+
+let test_no_overflow_sub a b =
+ Printf.printf "Misc.no_overflow_sub %s %s = %b\n"
+ (print_int a)
+ (print_int b)
+ (Misc.no_overflow_sub a b)
+
+let test_no_overflow_mul a b =
+ Printf.printf "Misc.no_overflow_mul %s %s = %b\n"
+ (print_int a)
+ (print_int b)
+ (Misc.no_overflow_mul a b)
+
+let cartesian_product l1 l2 =
+ List.concat
+ (l1 |> List.map (fun v1 ->
+ l2 |> List.map (fun v2 ->
+ (v1, v2))))
+
+let () =
+ let ints = [ 0; 1; 2; max_int; -1; -2; min_int ] in
+ let int_pairs = cartesian_product ints ints in
+ int_pairs |> List.iter (fun (a, b) -> test_no_overflow_add a b);
+ int_pairs |> List.iter (fun (a, b) -> test_no_overflow_sub a b);
+ int_pairs |> List.iter (fun (a, b) -> test_no_overflow_mul a b)
--- /dev/null
+Misc.no_overflow_add 0 0 = true
+Misc.no_overflow_add 0 1 = true
+Misc.no_overflow_add 0 2 = true
+Misc.no_overflow_add 0 max_int = true
+Misc.no_overflow_add 0 -1 = true
+Misc.no_overflow_add 0 -2 = true
+Misc.no_overflow_add 0 min_int = true
+Misc.no_overflow_add 1 0 = true
+Misc.no_overflow_add 1 1 = true
+Misc.no_overflow_add 1 2 = true
+Misc.no_overflow_add 1 max_int = false
+Misc.no_overflow_add 1 -1 = true
+Misc.no_overflow_add 1 -2 = true
+Misc.no_overflow_add 1 min_int = true
+Misc.no_overflow_add 2 0 = true
+Misc.no_overflow_add 2 1 = true
+Misc.no_overflow_add 2 2 = true
+Misc.no_overflow_add 2 max_int = false
+Misc.no_overflow_add 2 -1 = true
+Misc.no_overflow_add 2 -2 = true
+Misc.no_overflow_add 2 min_int = true
+Misc.no_overflow_add max_int 0 = true
+Misc.no_overflow_add max_int 1 = false
+Misc.no_overflow_add max_int 2 = false
+Misc.no_overflow_add max_int max_int = false
+Misc.no_overflow_add max_int -1 = true
+Misc.no_overflow_add max_int -2 = true
+Misc.no_overflow_add max_int min_int = true
+Misc.no_overflow_add -1 0 = true
+Misc.no_overflow_add -1 1 = true
+Misc.no_overflow_add -1 2 = true
+Misc.no_overflow_add -1 max_int = true
+Misc.no_overflow_add -1 -1 = true
+Misc.no_overflow_add -1 -2 = true
+Misc.no_overflow_add -1 min_int = false
+Misc.no_overflow_add -2 0 = true
+Misc.no_overflow_add -2 1 = true
+Misc.no_overflow_add -2 2 = true
+Misc.no_overflow_add -2 max_int = true
+Misc.no_overflow_add -2 -1 = true
+Misc.no_overflow_add -2 -2 = true
+Misc.no_overflow_add -2 min_int = false
+Misc.no_overflow_add min_int 0 = true
+Misc.no_overflow_add min_int 1 = true
+Misc.no_overflow_add min_int 2 = true
+Misc.no_overflow_add min_int max_int = true
+Misc.no_overflow_add min_int -1 = false
+Misc.no_overflow_add min_int -2 = false
+Misc.no_overflow_add min_int min_int = false
+Misc.no_overflow_sub 0 0 = true
+Misc.no_overflow_sub 0 1 = true
+Misc.no_overflow_sub 0 2 = true
+Misc.no_overflow_sub 0 max_int = true
+Misc.no_overflow_sub 0 -1 = true
+Misc.no_overflow_sub 0 -2 = true
+Misc.no_overflow_sub 0 min_int = false
+Misc.no_overflow_sub 1 0 = true
+Misc.no_overflow_sub 1 1 = true
+Misc.no_overflow_sub 1 2 = true
+Misc.no_overflow_sub 1 max_int = true
+Misc.no_overflow_sub 1 -1 = true
+Misc.no_overflow_sub 1 -2 = true
+Misc.no_overflow_sub 1 min_int = false
+Misc.no_overflow_sub 2 0 = true
+Misc.no_overflow_sub 2 1 = true
+Misc.no_overflow_sub 2 2 = true
+Misc.no_overflow_sub 2 max_int = true
+Misc.no_overflow_sub 2 -1 = true
+Misc.no_overflow_sub 2 -2 = true
+Misc.no_overflow_sub 2 min_int = false
+Misc.no_overflow_sub max_int 0 = true
+Misc.no_overflow_sub max_int 1 = true
+Misc.no_overflow_sub max_int 2 = true
+Misc.no_overflow_sub max_int max_int = true
+Misc.no_overflow_sub max_int -1 = false
+Misc.no_overflow_sub max_int -2 = false
+Misc.no_overflow_sub max_int min_int = false
+Misc.no_overflow_sub -1 0 = true
+Misc.no_overflow_sub -1 1 = true
+Misc.no_overflow_sub -1 2 = true
+Misc.no_overflow_sub -1 max_int = true
+Misc.no_overflow_sub -1 -1 = true
+Misc.no_overflow_sub -1 -2 = true
+Misc.no_overflow_sub -1 min_int = true
+Misc.no_overflow_sub -2 0 = true
+Misc.no_overflow_sub -2 1 = true
+Misc.no_overflow_sub -2 2 = true
+Misc.no_overflow_sub -2 max_int = false
+Misc.no_overflow_sub -2 -1 = true
+Misc.no_overflow_sub -2 -2 = true
+Misc.no_overflow_sub -2 min_int = true
+Misc.no_overflow_sub min_int 0 = true
+Misc.no_overflow_sub min_int 1 = false
+Misc.no_overflow_sub min_int 2 = false
+Misc.no_overflow_sub min_int max_int = false
+Misc.no_overflow_sub min_int -1 = true
+Misc.no_overflow_sub min_int -2 = true
+Misc.no_overflow_sub min_int min_int = true
+Misc.no_overflow_mul 0 0 = true
+Misc.no_overflow_mul 0 1 = true
+Misc.no_overflow_mul 0 2 = true
+Misc.no_overflow_mul 0 max_int = true
+Misc.no_overflow_mul 0 -1 = true
+Misc.no_overflow_mul 0 -2 = true
+Misc.no_overflow_mul 0 min_int = true
+Misc.no_overflow_mul 1 0 = true
+Misc.no_overflow_mul 1 1 = true
+Misc.no_overflow_mul 1 2 = true
+Misc.no_overflow_mul 1 max_int = true
+Misc.no_overflow_mul 1 -1 = true
+Misc.no_overflow_mul 1 -2 = true
+Misc.no_overflow_mul 1 min_int = true
+Misc.no_overflow_mul 2 0 = true
+Misc.no_overflow_mul 2 1 = true
+Misc.no_overflow_mul 2 2 = true
+Misc.no_overflow_mul 2 max_int = false
+Misc.no_overflow_mul 2 -1 = true
+Misc.no_overflow_mul 2 -2 = true
+Misc.no_overflow_mul 2 min_int = false
+Misc.no_overflow_mul max_int 0 = true
+Misc.no_overflow_mul max_int 1 = true
+Misc.no_overflow_mul max_int 2 = false
+Misc.no_overflow_mul max_int max_int = false
+Misc.no_overflow_mul max_int -1 = true
+Misc.no_overflow_mul max_int -2 = false
+Misc.no_overflow_mul max_int min_int = false
+Misc.no_overflow_mul -1 0 = true
+Misc.no_overflow_mul -1 1 = true
+Misc.no_overflow_mul -1 2 = true
+Misc.no_overflow_mul -1 max_int = true
+Misc.no_overflow_mul -1 -1 = true
+Misc.no_overflow_mul -1 -2 = true
+Misc.no_overflow_mul -1 min_int = false
+Misc.no_overflow_mul -2 0 = true
+Misc.no_overflow_mul -2 1 = true
+Misc.no_overflow_mul -2 2 = true
+Misc.no_overflow_mul -2 max_int = false
+Misc.no_overflow_mul -2 -1 = true
+Misc.no_overflow_mul -2 -2 = true
+Misc.no_overflow_mul -2 min_int = false
+Misc.no_overflow_mul min_int 0 = true
+Misc.no_overflow_mul min_int 1 = true
+Misc.no_overflow_mul min_int 2 = false
+Misc.no_overflow_mul min_int max_int = false
+Misc.no_overflow_mul min_int -1 = false
+Misc.no_overflow_mul min_int -2 = false
+Misc.no_overflow_mul min_int min_int = false
+
+All tests succeeded.
+(* TEST
+include config
+include testing
+binary_modules = "misc identifiable numbers strongly_connected_components"
+* bytecode
+*)
+
module Int = Numbers.Int
module SCC = Strongly_connected_components.Make (Int)
+++ /dev/null
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Xavier Clerc, SED, INRIA Rocquencourt *
-#* *
-#* Copyright 2010 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-BASEDIR=../..
-FLAGS=-w A
-
-run-all:
- @$(OCAMLC) $(FLAGS) -c deprecated_module.mli
- @$(OCAMLC) $(FLAGS) -c module_without_cmx.mli
- @$(OCAMLC) $(FLAGS) -c w32.mli
- @$(OCAMLC) $(FLAGS) -c w60.mli
- @for file in *.ml; do \
- printf " ... testing '$$file':"; \
- F="`basename $$file .ml`"; \
- $(OCAMLC) $(FLAGS) -c $$file 2>$$F.result; \
- $(DIFF) $$F.reference $$F.result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- done;
- @for file in *.opt.ml; do \
- printf " ... testing '$$file' with ocamlopt:"; \
- if $(BYTECODE_ONLY); then echo " => skipped"; else \
- F="`basename $$file .ml`"; \
- $(OCAMLOPT) $(FLAGS) -c $$file 2>$$F.opt_result; \
- $(DIFF) $$F.opt_reference $$F.opt_result >/dev/null \
- && echo " => passed" || echo " => failed"; \
- fi \
- done;
- @for file in *.opt_backend.ml; do \
- printf " ... testing '$$file' with ocamlopt:"; \
- if $(BYTECODE_ONLY); then echo " => skipped"; else \
- F="`basename $$file .ml`"; \
- $(OCAMLOPT) $(FLAGS) -c $$file 2>$$F.$(BACKEND).opt_result; \
- $(DIFF) $$F.$(BACKEND).opt_reference $$F.$(BACKEND).opt_result \
- >/dev/null \
- && echo " => passed" || echo " => failed"; \
- fi \
- done;
-
-promote: defaultpromote
-
-clean: defaultclean
- @rm -f *.result *.opt_result
-
-include $(BASEDIR)/makefiles/Makefile.common
-
-ifeq "$(FLAMBDA)" "true"
-BACKEND=flambda
-else
-BACKEND=clambda
-endif
--- /dev/null
+File "deprecated_module.ml", line 16, characters 8-11:
+Warning 3: deprecated: module M
+File "deprecated_module.ml", line 17, characters 8-9:
+Warning 3: deprecated: module M
+(* TEST
+
+flags = "-w A"
+
+* bytecode
+
+*)
+
module M = struct
type t = int
+++ /dev/null
-File "deprecated_module.ml", line 8, characters 8-11:
-Warning 3: deprecated: module M
-File "deprecated_module.ml", line 9, characters 8-9:
-Warning 3: deprecated: module M
--- /dev/null
+File "deprecated_module_assigment.ml", line 17, characters 33-34:
+Warning 3: deprecated: x
+DEPRECATED
+ File "deprecated_module_assigment.ml", line 12, characters 2-41:
+ Definition
+ File "deprecated_module_assigment.ml", line 17, characters 15-26:
+ Expected signature
+File "deprecated_module_assigment.ml", line 23, characters 13-14:
+Warning 3: deprecated: x
+DEPRECATED
+ File "deprecated_module_assigment.ml", line 12, characters 2-41:
+ Definition
+ File "deprecated_module_assigment.ml", line 21, characters 17-28:
+ Expected signature
+File "deprecated_module_assigment.ml", line 33, characters 39-78:
+Warning 3: deprecated: A
+ File "deprecated_module_assigment.ml", line 33, characters 55-70:
+ Definition
+ File "deprecated_module_assigment.ml", line 33, characters 27-28:
+ Expected signature
+File "deprecated_module_assigment.ml", line 37, characters 2-20:
+Warning 3: deprecated: A
+ File "deprecated_module_assigment.ml", line 36, characters 11-26:
+ Definition
+ File "deprecated_module_assigment.ml", line 37, characters 15-16:
+ Expected signature
+File "deprecated_module_assigment.ml", line 45, characters 0-58:
+Warning 3: deprecated: mutating field x
+ File "deprecated_module_assigment.ml", line 45, characters 17-53:
+ Definition
+ File "deprecated_module_assigment.ml", line 44, characters 14-28:
+ Expected signature
+File "deprecated_module_assigment.ml", line 49, characters 2-31:
+Warning 3: deprecated: mutating field x
+ File "deprecated_module_assigment.ml", line 48, characters 12-48:
+ Definition
+ File "deprecated_module_assigment.ml", line 49, characters 16-30:
+ Expected signature
+File "deprecated_module_assigment.ml", line 54, characters 37-75:
+Warning 3: deprecated: t
+ File "deprecated_module_assigment.ml", line 54, characters 44-71:
+ Definition
+ File "deprecated_module_assigment.ml", line 54, characters 18-30:
+ Expected signature
+File "deprecated_module_assigment.ml", line 60, characters 0-52:
+Warning 3: deprecated: c
+FOO
+ File "deprecated_module_assigment.ml", line 60, characters 7-48:
+ Definition
+ File "deprecated_module_assigment.ml", line 59, characters 4-24:
+ Expected signature
+File "deprecated_module_assigment.ml", line 64, characters 0-57:
+Warning 3: deprecated: c
+FOO
+ File "deprecated_module_assigment.ml", line 64, characters 7-53:
+ Definition
+ File "deprecated_module_assigment.ml", line 63, characters 4-29:
+ Expected signature
+File "deprecated_module_assigment.ml", line 71, characters 0-55:
+Warning 3: deprecated: S
+FOO
+ File "deprecated_module_assigment.ml", line 71, characters 7-51:
+ Definition
+ File "deprecated_module_assigment.ml", line 70, characters 4-27:
+ Expected signature
+File "deprecated_module_assigment.ml", line 82, characters 0-53:
+Warning 3: deprecated: M
+FOO
+ File "deprecated_module_assigment.ml", line 82, characters 7-49:
+ Definition
+ File "deprecated_module_assigment.ml", line 81, characters 4-22:
+ Expected signature
+(* TEST
+
+flags = "-w A"
+
+* bytecode
+
+*)
+
(* Values *)
module X : sig
module Z : sig val x : int [@@deprecated "..."] end = X
-module F(A : sig val x : int end) = struct end
+module F(A : sig val x : int end) = struct let _ = A.x end
module B = F(X)
+++ /dev/null
-File "deprecated_module_assigment.ml", line 9, characters 33-34:
-Warning 3: deprecated: x
-DEPRECATED
- File "deprecated_module_assigment.ml", line 4, characters 2-41:
- Definition
- File "deprecated_module_assigment.ml", line 9, characters 15-26:
- Expected signature
-File "deprecated_module_assigment.ml", line 15, characters 13-14:
-Warning 3: deprecated: x
-DEPRECATED
- File "deprecated_module_assigment.ml", line 4, characters 2-41:
- Definition
- File "deprecated_module_assigment.ml", line 13, characters 17-28:
- Expected signature
-File "deprecated_module_assigment.ml", line 25, characters 39-78:
-Warning 3: deprecated: A
- File "deprecated_module_assigment.ml", line 25, characters 55-70:
- Definition
- File "deprecated_module_assigment.ml", line 25, characters 27-28:
- Expected signature
-File "deprecated_module_assigment.ml", line 29, characters 2-20:
-Warning 3: deprecated: A
- File "deprecated_module_assigment.ml", line 28, characters 11-26:
- Definition
- File "deprecated_module_assigment.ml", line 29, characters 15-16:
- Expected signature
-File "deprecated_module_assigment.ml", line 37, characters 0-58:
-Warning 3: deprecated: mutating field x
- File "deprecated_module_assigment.ml", line 37, characters 17-53:
- Definition
- File "deprecated_module_assigment.ml", line 36, characters 14-28:
- Expected signature
-File "deprecated_module_assigment.ml", line 41, characters 2-31:
-Warning 3: deprecated: mutating field x
- File "deprecated_module_assigment.ml", line 40, characters 12-48:
- Definition
- File "deprecated_module_assigment.ml", line 41, characters 16-30:
- Expected signature
-File "deprecated_module_assigment.ml", line 46, characters 37-75:
-Warning 3: deprecated: t
- File "deprecated_module_assigment.ml", line 46, characters 44-71:
- Definition
- File "deprecated_module_assigment.ml", line 46, characters 18-30:
- Expected signature
-File "deprecated_module_assigment.ml", line 52, characters 0-52:
-Warning 3: deprecated: c
-FOO
- File "deprecated_module_assigment.ml", line 52, characters 7-48:
- Definition
- File "deprecated_module_assigment.ml", line 51, characters 4-24:
- Expected signature
-File "deprecated_module_assigment.ml", line 56, characters 0-57:
-Warning 3: deprecated: c
-FOO
- File "deprecated_module_assigment.ml", line 56, characters 7-53:
- Definition
- File "deprecated_module_assigment.ml", line 55, characters 4-29:
- Expected signature
-File "deprecated_module_assigment.ml", line 63, characters 0-55:
-Warning 3: deprecated: S
-FOO
- File "deprecated_module_assigment.ml", line 63, characters 7-51:
- Definition
- File "deprecated_module_assigment.ml", line 62, characters 4-27:
- Expected signature
-File "deprecated_module_assigment.ml", line 74, characters 0-53:
-Warning 3: deprecated: M
-FOO
- File "deprecated_module_assigment.ml", line 74, characters 7-49:
- Definition
- File "deprecated_module_assigment.ml", line 73, characters 4-22:
- Expected signature
--- /dev/null
+File "deprecated_module_use.ml", line 18, characters 5-22:
+Warning 3: deprecated: module Deprecated_module
+
+ As you could guess, Deprecated_module is deprecated.
+ Please use something else!
+
+File "deprecated_module_use.ml", line 20, characters 9-12:
+Warning 3: deprecated: module Deprecated_module.M
+File "deprecated_module_use.ml", line 20, characters 9-12:
+Warning 3: deprecated: Deprecated_module.M.t
+File "deprecated_module_use.ml", line 22, characters 5-6:
+Warning 3: deprecated: module Deprecated_module.M
+File "deprecated_module_use.ml", line 23, characters 8-9:
+Warning 3: deprecated: Deprecated_module.M.x
+(* TEST
+
+modules = "deprecated_module.mli deprecated_module.ml"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+flags = "-w a"
+module = "deprecated_module.mli"
+*** ocamlc.byte
+module = "deprecated_module.ml"
+**** ocamlc.byte
+flags = "-w A"
+module = "deprecated_module_use.ml"
+***** check-ocamlc.byte-output
+
+*)
+
open Deprecated_module
type s = M.t
+++ /dev/null
-File "deprecated_module_use.ml", line 1, characters 5-22:
-Warning 3: deprecated: module Deprecated_module
-
- As you could guess, Deprecated_module is deprecated.
- Please use something else!
-
-File "deprecated_module_use.ml", line 3, characters 9-12:
-Warning 3: deprecated: module Deprecated_module.M
-File "deprecated_module_use.ml", line 3, characters 9-12:
-Warning 3: deprecated: Deprecated_module.M.t
-File "deprecated_module_use.ml", line 5, characters 5-6:
-Warning 3: deprecated: module Deprecated_module.M
-File "deprecated_module_use.ml", line 6, characters 8-9:
-Warning 3: deprecated: Deprecated_module.M.x
--- /dev/null
+deprecated_module_assigment.ml
+deprecated_module.ml
+deprecated_module_use.ml
+w01.ml
+w04_failure.ml
+w04.ml
+w06.ml
+w32b.ml
+w32.ml
+w33.ml
+w45.ml
+w47_inline.ml
+w50.ml
+w51_bis.ml
+w51.ml
+w52.ml
+w53.ml
+w54.ml
+w55.ml
+w58.ml
+w59.ml
+w60.ml
--- /dev/null
+File "w01.ml", line 14, characters 12-14:
+Warning 2: this is not the end of a comment.
+File "w01.ml", line 20, characters 0-3:
+Warning 5: this function application is partial,
+maybe some arguments are missing.
+File "w01.ml", line 30, characters 4-5:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+0
+File "w01.ml", line 35, characters 0-1:
+Warning 10: this expression should have type unit.
+File "w01.ml", line 19, characters 8-9:
+Warning 27: unused variable y.
+File "w01.ml", line 42, characters 2-3:
+Warning 11: this match case is unused.
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
(* C *)
+++ /dev/null
-File "w01.ml", line 4, characters 12-14:
-Warning 2: this is not the end of a comment.
-File "w01.ml", line 10, characters 0-3:
-Warning 5: this function application is partial,
-maybe some arguments are missing.
-File "w01.ml", line 20, characters 4-5:
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-0
-File "w01.ml", line 25, characters 0-1:
-Warning 10: this expression should have type unit.
-File "w01.ml", line 9, characters 8-9:
-Warning 27: unused variable y.
-File "w01.ml", line 32, characters 2-3:
-Warning 11: this match case is unused.
--- /dev/null
+File "w04.ml", line 21, characters 10-40:
+Warning 4: this pattern-matching is fragile.
+It will remain exhaustive when constructors are added to type t.
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
+
[@@@ocaml.warning "+4"]
type expr = E of int [@@unboxed]
+++ /dev/null
-File "w04.ml", line 10, characters 10-40:
-Warning 4: this pattern-matching is fragile.
-It will remain exhaustive when constructors are added to type t.
--- /dev/null
+File "w04_failure.ml", line 20, characters 2-78:
+Warning 4: this pattern-matching is fragile.
+It will remain exhaustive when constructors are added to type repr.
+File "w04_failure.ml", line 20, characters 2-78:
+Warning 4: this pattern-matching is fragile.
+It will remain exhaustive when constructors are added to type ab.
+File "w04_failure.ml", line 20, characters 2-78:
+Warning 4: this pattern-matching is fragile.
+It will remain exhaustive when constructors are added to type xy.
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
+
type ab = A | B
type xy = X | Y
+++ /dev/null
-File "w04_failure.ml", line 9, characters 2-78:
-Warning 4: this pattern-matching is fragile.
-It will remain exhaustive when constructors are added to type repr.
-File "w04_failure.ml", line 9, characters 2-78:
-Warning 4: this pattern-matching is fragile.
-It will remain exhaustive when constructors are added to type ab.
-File "w04_failure.ml", line 9, characters 2-78:
-Warning 4: this pattern-matching is fragile.
-It will remain exhaustive when constructors are added to type xy.
--- /dev/null
+File "w06.ml", line 16, characters 9-12:
+Warning 6: label bar was omitted in the application of this function.
+File "w06.ml", line 17, characters 9-12:
+Warning 6: labels foo, baz were omitted in the application of this function.
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
+
let foo ~bar = ignore bar (* one label *)
let bar ~foo ~baz = ignore (foo, baz) (* two labels *)
+++ /dev/null
-File "w06.ml", line 5, characters 9-12:
-Warning 6: label bar was omitted in the application of this function.
-File "w06.ml", line 6, characters 9-12:
-Warning 6: labels foo, baz were omitted in the application of this function.
--- /dev/null
+File "w32.ml", line 40, characters 24-25:
+Warning 39: unused rec flag.
+File "w32.ml", line 43, characters 24-25:
+Warning 39: unused rec flag.
+File "w32.ml", line 20, characters 4-5:
+Warning 32: unused value h.
+File "w32.ml", line 26, characters 4-5:
+Warning 32: unused value j.
+File "w32.ml", line 28, characters 4-5:
+Warning 32: unused value k.
+File "w32.ml", line 41, characters 4-5:
+Warning 32: unused value r.
+File "w32.ml", line 44, characters 20-21:
+Warning 32: unused value t.
+File "w32.ml", line 46, characters 24-25:
+Warning 32: unused value u.
+File "w32.ml", line 47, characters 4-5:
+Warning 32: unused value v.
+File "w32.ml", line 55, characters 22-23:
+Warning 32: unused value g.
+File "w32.ml", line 56, characters 22-23:
+Warning 32: unused value h.
+File "w32.ml", line 59, characters 22-23:
+Warning 32: unused value k.
+File "w32.ml", line 52, characters 0-174:
+Warning 60: unused module M.
+File "w32.ml", line 63, characters 18-29:
+Warning 32: unused value x.
+File "w32.ml", line 65, characters 18-29:
+Warning 32: unused value x.
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+module = "w32.mli"
+*** ocamlc.byte
+module = "w32.ml"
+**** check-ocamlc.byte-output
+
+*)
+
(* from MPR#7624 *)
let[@warning "-32"] f x = x
let j x = x
and[@warning "+32"] k x = x
end
+
+(* unused values in functor argument *)
+module F (X : sig val x : int end) = struct end
+
+module G (X : sig val x : int end) = X
+
+module H (X : sig val x : int end) = X
val n : 'a -> 'a
val o : 'a -> 'a
+
+(* value in functor argument *)
+module F (X : sig val x : int end) : sig end
+
+module G (X : sig val x : int end) : sig end
+
+module H (X : sig val x : int end) : sig val x : int end
+++ /dev/null
-File "w32.ml", line 27, characters 24-25:
-Warning 39: unused rec flag.
-File "w32.ml", line 30, characters 24-25:
-Warning 39: unused rec flag.
-File "w32.ml", line 7, characters 4-5:
-Warning 32: unused value h.
-File "w32.ml", line 13, characters 4-5:
-Warning 32: unused value j.
-File "w32.ml", line 15, characters 4-5:
-Warning 32: unused value k.
-File "w32.ml", line 28, characters 4-5:
-Warning 32: unused value r.
-File "w32.ml", line 31, characters 20-21:
-Warning 32: unused value t.
-File "w32.ml", line 33, characters 24-25:
-Warning 32: unused value u.
-File "w32.ml", line 34, characters 4-5:
-Warning 32: unused value v.
-File "w32.ml", line 42, characters 22-23:
-Warning 32: unused value g.
-File "w32.ml", line 43, characters 22-23:
-Warning 32: unused value h.
-File "w32.ml", line 46, characters 22-23:
-Warning 32: unused value k.
-File "w32.ml", line 39, characters 0-174:
-Warning 60: unused module M.
--- /dev/null
+File "w32b.ml", line 13, characters 18-24:
+Warning 34: unused type t.
--- /dev/null
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
+
+(* Check that [t] is considered unused without an .mli file (see GPR#1358) *)
+module Q (M : sig type t end) = struct end
--- /dev/null
+File "w33.ml", line 19, characters 6-11:
+Warning 33: unused open M.
+File "w33.ml", line 27, characters 0-6:
+Warning 33: unused open M.
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
+
(** Test unused opens, in particular in presence of
pattern open *)
+++ /dev/null
-File "w33.ml", line 8, characters 6-11:
-Warning 33: unused open M.
-File "w33.ml", line 16, characters 0-6:
-Warning 33: unused open M.
--- /dev/null
+File "w45.ml", line 24, characters 2-9:
+Warning 45: this open statement shadows the constructor X (which is later used)
+File "w45.ml", line 26, characters 14-15:
+Warning 41: X belongs to several types: T2.s T1.s
+The first one was selected. Please disambiguate if this is wrong.
+File "w45.ml", line 23, characters 2-9:
+Warning 33: unused open T1.
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
+
module T1 = struct
type t = A
type s = X
+++ /dev/null
-File "w45.ml", line 13, characters 2-9:
-Warning 45: this open statement shadows the constructor X (which is later used)
-File "w45.ml", line 15, characters 14-15:
-Warning 41: X belongs to several types: T2.s T1.s
-The first one was selected. Please disambiguate if this is wrong.
-File "w45.ml", line 12, characters 2-9:
-Warning 33: unused open T1.
--- /dev/null
+File "w47_inline.ml", line 15, characters 23-29:
+Warning 47: illegal payload for attribute 'inline'.
+It must be either empty, 'always' or 'never'
+File "w47_inline.ml", line 16, characters 23-29:
+Warning 47: illegal payload for attribute 'inline'.
+It must be either empty, 'always' or 'never'
+File "w47_inline.ml", line 17, characters 23-29:
+Warning 47: illegal payload for attribute 'inline'.
+It must be either empty, 'always' or 'never'
+File "w47_inline.ml", line 18, characters 23-29:
+Warning 47: illegal payload for attribute 'inline'.
+It must be either empty, 'always' or 'never'
+File "w47_inline.ml", line 23, characters 15-22:
+Warning 47: illegal payload for attribute 'inlined'.
+It must be either empty, 'always' or 'never'
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
let a = (fun x -> x) [@inline] (* accepted *)
let b = (fun x -> x) [@inline never] (* accepted *)
+++ /dev/null
-File "w47_inline.ml", line 13, characters 15-22:
-Warning 47: illegal payload for attribute 'inlined'.
-It must be either empty, 'always' or 'never'
-File "w47_inline.ml", line 8, characters 23-29:
-Warning 47: illegal payload for attribute 'inline'.
-It must be either empty, 'always' or 'never'
-File "w47_inline.ml", line 7, characters 23-29:
-Warning 47: illegal payload for attribute 'inline'.
-It must be either empty, 'always' or 'never'
-File "w47_inline.ml", line 6, characters 23-29:
-Warning 47: illegal payload for attribute 'inline'.
-It must be either empty, 'always' or 'never'
-File "w47_inline.ml", line 5, characters 23-29:
-Warning 47: illegal payload for attribute 'inline'.
-It must be either empty, 'always' or 'never'
--- /dev/null
+File "w50.ml", line 13, characters 2-17:
+Warning 60: unused module L.
+File "w50.ml", line 17, characters 2-16:
+Warning 60: unused module Y1.
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
+
module A : sig end = struct
module L = List
+++ /dev/null
-File "w50.ml", line 2, characters 2-17:
-Warning 60: unused module L.
-File "w50.ml", line 6, characters 2-16:
-Warning 60: unused module Y1.
--- /dev/null
+File "w51.ml", line 14, characters 13-37:
+Warning 51: expected tailcall
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
let rec fact = function
| 1 -> 1
+++ /dev/null
-File "w51.ml", line 4, characters 13-37:
-Warning 51: expected tailcall
--- /dev/null
+File "w51_bis.ml", line 15, characters 12-48:
+Warning 51: expected tailcall
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
+
let rec foldl op acc = function
[] -> acc
| x :: xs ->
+++ /dev/null
-File "w51_bis.ml", line 4, characters 12-48:
-Warning 51: expected tailcall
--- /dev/null
+File "w52.ml", line 12, characters 38-43:
+Warning 52: Code should not depend on the actual values of
+this constructor's arguments. They are only for information
+and may change in future versions. (See manual section 9.5)
+File "w52.ml", line 20, characters 7-17:
+Warning 52: Code should not depend on the actual values of
+this constructor's arguments. They are only for information
+and may change in future versions. (See manual section 9.5)
+File "w52.ml", line 25, characters 8-10:
+Warning 52: Code should not depend on the actual values of
+this constructor's arguments. They are only for information
+and may change in future versions. (See manual section 9.5)
--- /dev/null
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
+
+let () = try () with Invalid_argument "Any" -> ();;
+
+type t =
+ | Warn of string [@ocaml.warn_on_literal_pattern]
+ | Without_warning of string
+ | Warn' of nativeint [@ocaml.warn_on_literal_pattern];;
+
+let f = function
+| Warn "anything" -> ()
+| Warn _ | Warn' _ | Without_warning _ -> ()
+;;
+
+let g = function
+| Warn' 0n -> ()
+| Warn _ | Warn' _ | Without_warning _ -> ()
+;;
+
+
+let h = function
+| Without_warning "outside" -> ()
+| Warn _ | Warn' _ | Without_warning _ -> ()
+;;
--- /dev/null
+File "w53.ml", line 12, characters 4-5:
+Warning 32: unused value h.
+File "w53.ml", line 12, characters 14-20:
+Warning 53: the "inline" attribute cannot appear in this context
+File "w53.ml", line 13, characters 14-26:
+Warning 53: the "ocaml.inline" attribute cannot appear in this context
+File "w53.ml", line 15, characters 14-21:
+Warning 53: the "inlined" attribute cannot appear in this context
+File "w53.ml", line 16, characters 14-27:
+Warning 53: the "ocaml.inlined" attribute cannot appear in this context
+File "w53.ml", line 19, characters 16-23:
+Warning 53: the "inlined" attribute cannot appear in this context
+File "w53.ml", line 21, characters 14-22:
+Warning 53: the "tailcall" attribute cannot appear in this context
+File "w53.ml", line 22, characters 14-28:
+Warning 53: the "ocaml.tailcall" attribute cannot appear in this context
+File "w53.ml", line 25, characters 16-24:
+Warning 53: the "tailcall" attribute cannot appear in this context
+File "w53.ml", line 33, characters 0-32:
+Warning 53: the "inline" attribute cannot appear in this context
+File "w53.ml", line 34, characters 0-39:
+Warning 53: the "inline" attribute cannot appear in this context
+File "w53.ml", line 40, characters 16-22:
+Warning 53: the "inline" attribute cannot appear in this context
+File "w53.ml", line 41, characters 17-29:
+Warning 53: the "ocaml.inline" attribute cannot appear in this context
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
let h x = x [@inline] (* rejected *)
let h x = x [@ocaml.inline] (* rejected *)
module F' = (A [@ocaml.inlined])(struct end) (* accepted *)
module G = (A [@inline])(struct end) (* rejected *)
module G' = (A [@ocaml.inline])(struct end) (* rejected *)
+
+module H = Set.Make [@inlined] (Int32) (* GPR#1808 *)
+++ /dev/null
-File "w53.ml", line 2, characters 4-5:
-Warning 32: unused value h.
-File "w53.ml", line 31, characters 17-29:
-Warning 53: the "ocaml.inline" attribute cannot appear in this context
-File "w53.ml", line 30, characters 16-22:
-Warning 53: the "inline" attribute cannot appear in this context
-File "w53.ml", line 24, characters 0-39:
-Warning 53: the "inline" attribute cannot appear in this context
-File "w53.ml", line 23, characters 0-32:
-Warning 53: the "inline" attribute cannot appear in this context
-File "w53.ml", line 15, characters 16-24:
-Warning 53: the "tailcall" attribute cannot appear in this context
-File "w53.ml", line 12, characters 14-28:
-Warning 53: the "ocaml.tailcall" attribute cannot appear in this context
-File "w53.ml", line 11, characters 14-22:
-Warning 53: the "tailcall" attribute cannot appear in this context
-File "w53.ml", line 9, characters 16-23:
-Warning 53: the "inlined" attribute cannot appear in this context
-File "w53.ml", line 6, characters 14-27:
-Warning 53: the "ocaml.inlined" attribute cannot appear in this context
-File "w53.ml", line 5, characters 14-21:
-Warning 53: the "inlined" attribute cannot appear in this context
-File "w53.ml", line 3, characters 14-26:
-Warning 53: the "ocaml.inline" attribute cannot appear in this context
-File "w53.ml", line 2, characters 14-20:
-Warning 53: the "inline" attribute cannot appear in this context
--- /dev/null
+File "w54.ml", line 12, characters 33-39:
+Warning 54: the "inline" attribute is used more than once on this expression
+File "w54.ml", line 13, characters 51-63:
+Warning 54: the "ocaml.inline" attribute is used more than once on this expression
+File "w54.ml", line 15, characters 26-39:
+Warning 54: the "ocaml.inlined" attribute is used more than once on this expression
+File "w54.ml", line 19, characters 0-43:
+Warning 54: the "inline" attribute is used more than once on this expression
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
let f = (fun x -> x) [@inline] [@inline never]
let g = (fun x -> x) [@inline] [@something_else] [@ocaml.inline]
+++ /dev/null
-File "w54.ml", line 9, characters 0-43:
-Warning 54: the "inline" attribute is used more than once on this expression
-File "w54.ml", line 5, characters 26-39:
-Warning 54: the "ocaml.inlined" attribute is used more than once on this expression
-File "w54.ml", line 3, characters 51-63:
-Warning 54: the "ocaml.inline" attribute is used more than once on this expression
-File "w54.ml", line 2, characters 33-39:
-Warning 54: the "inline" attribute is used more than once on this expression
--- /dev/null
+File "w55.ml", line 33, characters 10-26:
+Warning 55: Cannot inline: [@inlined] attributes may not be used on partial applications
+File "w55.ml", line 29, characters 10-27:
+Warning 55: Cannot inline: [@inlined] attribute was not used on this function application (the optimizer did not know what function was being applied)
+File "w55.ml", line 39, characters 12-30:
+Warning 55: Cannot inline: [@inlined] attribute was not used on this function application (the optimizer did not know what function was being applied)
--- /dev/null
+(* TEST
+
+flags = "-w A"
+compile_only = "true"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+
+* no-flambda
+** setup-ocamlopt.byte-build-env
+*** ocamlopt.byte
+**** check-ocamlopt.byte-output
+
+* flambda
+compiler_reference = "${test_source_directory}/w55.flambda.reference"
+** setup-ocamlopt.byte-build-env
+*** ocamlopt.byte
+**** check-ocamlopt.byte-output
+
+*)
+
+let f = (fun x -> x + 1) [@inline never]
+
+let g x = (f [@inlined]) x
+
+let h = ref f
+
+let i x = (!h [@inlined]) x
+
+let j x y = x + y
+
+let h x = (j [@inlined]) x
+
+let a x =
+ let b = x + 1 in
+ fun y -> y + b
+
+let b x y = (a [@inlined]) x y
+
+let c x = x + 1 [@@inline never]
+let d x = (c [@inlined]) x
--- /dev/null
+File "w55.ml", line 25, characters 10-26:
+Warning 55: Cannot inline: Function information unavailable
+File "w55.ml", line 29, characters 10-27:
+Warning 55: Cannot inline: Unknown function
+File "w55.ml", line 33, characters 10-26:
+Warning 55: Cannot inline: Partial application
+File "w55.ml", line 39, characters 12-30:
+Warning 55: Cannot inline: Over-application
+File "w55.ml", line 39, characters 12-30:
+Warning 55: Cannot inline: Function information unavailable
+File "w55.ml", line 42, characters 10-26:
+Warning 55: Cannot inline: Function information unavailable
+++ /dev/null
-File "w55.opt_backend.ml", line 4, characters 10-26:
-Warning 55: Cannot inline: Function information unavailable
-File "w55.opt_backend.ml", line 8, characters 10-27:
-Warning 55: Cannot inline: Unknown function
-File "w55.opt_backend.ml", line 12, characters 10-26:
-Warning 55: Cannot inline: Partial application
-File "w55.opt_backend.ml", line 18, characters 12-30:
-Warning 55: Cannot inline: Over-application
-File "w55.opt_backend.ml", line 18, characters 12-30:
-Warning 55: Cannot inline: Function information unavailable
-File "w55.opt_backend.ml", line 21, characters 10-26:
-Warning 55: Cannot inline: Function information unavailable
+++ /dev/null
-File "w55.opt_backend.ml", line 12, characters 10-26:
-Warning 55: Cannot inline: [@inlined] attributes may not be used on partial applications
-File "w55.opt_backend.ml", line 8, characters 10-27:
-Warning 55: Cannot inline: [@inlined] attribute was not used on this function application (the optimizer did not know what function was being applied)
-File "w55.opt_backend.ml", line 18, characters 12-30:
-Warning 55: Cannot inline: [@inlined] attribute was not used on this function application (the optimizer did not know what function was being applied)
+++ /dev/null
-
-let f = (fun x -> x + 1) [@inline never]
-
-let g x = (f [@inlined]) x
-
-let h = ref f
-
-let i x = (!h [@inlined]) x
-
-let j x y = x + y
-
-let h x = (j [@inlined]) x
-
-let a x =
- let b = x + 1 in
- fun y -> y + b
-
-let b x y = (a [@inlined]) x y
-
-let c x = x + 1 [@@inline never]
-let d x = (c [@inlined]) x
--- /dev/null
+(* TEST
+
+flags = "-w A"
+files = "module_without_cmx.mli"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+module = "module_without_cmx.mli"
+*** ocamlc.byte
+module = "w58.ml"
+**** check-ocamlc.byte-output
+
+* setup-ocamlopt.byte-build-env
+** ocamlopt.byte
+module = "module_without_cmx.mli"
+*** ocamlopt.byte
+module = "w58.ml"
+**** check-ocamlopt.byte-output
+
+*)
+
+let () = print_endline (Module_without_cmx.id "Hello World")
--- /dev/null
+File "_none_", line 1:
+Warning 58: no cmx file was found in path for module Module_without_cmx, and its interface was not compiled with -opaque
+++ /dev/null
-
-let () = print_endline (Module_without_cmx.id "Hello World")
+++ /dev/null
-File "_none_", line 1:
-Warning 58: no cmx file was found in path for module Module_without_cmx, and its interface was not compiled with -opaque
--- /dev/null
+File "w59.ml", line 46, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected
+in this source file. Such assignments may generate incorrect code
+when using Flambda.
+File "w59.ml", line 47, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected
+in this source file. Such assignments may generate incorrect code
+when using Flambda.
+File "w59.ml", line 48, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected
+in this source file. Such assignments may generate incorrect code
+when using Flambda.
+File "w59.ml", line 49, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected
+in this source file. Such assignments may generate incorrect code
+when using Flambda.
+File "w59.ml", line 56, characters 2-7:
+Warning 59: A potential assignment to a non-mutable value was detected
+in this source file. Such assignments may generate incorrect code
+when using Flambda.
--- /dev/null
+(* TEST
+
+flags = "-w A"
+compile_only = "true"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+
+* no-flambda
+** setup-ocamlopt.byte-build-env
+*** ocamlopt.byte
+**** check-ocamlopt.byte-output
+
+* flambda
+compiler_reference = "${test_source_directory}/w59.flambda.reference"
+** setup-ocamlopt.byte-build-env
+*** ocamlopt.byte
+**** check-ocamlopt.byte-output
+
+*)
+
+(* Check that the warning 59 (assignment to immutable value) does not
+ trigger on those examples *)
+let a = Lazy.force (lazy "a")
+let b = Lazy.force (lazy 1)
+let c = Lazy.force (lazy 3.14)
+let d = Lazy.force (lazy 'a')
+let e = Lazy.force (lazy (fun x -> x+1))
+let rec f (x:int) : int = g x and g x = f x
+let h = Lazy.force (lazy f)
+let i = Lazy.force (lazy g)
+let j = Lazy.force (lazy 1L)
+let k = Lazy.force (lazy (1,2))
+let l = Lazy.force (lazy [|3.14|])
+let m = Lazy.force (lazy (Sys.opaque_identity 3.14))
+let n = Lazy.force (lazy None)
+
+(* Check that obviously wrong code is reported *)
+let o = (1,2)
+let p = fun x -> x
+let q = 3.14
+let r = 1
+
+let () =
+ Obj.set_field (Obj.repr o) 0 (Obj.repr 3);
+ Obj.set_field (Obj.repr p) 0 (Obj.repr 3);
+ Obj.set_field (Obj.repr q) 0 (Obj.repr 3);
+ Obj.set_field (Obj.repr r) 0 (Obj.repr 3)
+
+let set v =
+ Obj.set_field (Obj.repr v) 0 (Obj.repr 3)
+ [@@inline]
+
+let () =
+ set o
+
+(* Sys.opaque_identity hides all information and shouldn't warn *)
+
+let opaque = Sys.opaque_identity (1,2)
+let set_opaque =
+ Obj.set_field
+ (Obj.repr opaque)
+ 0
+ (Obj.repr 3)
+++ /dev/null
-File "w59.opt_backend.ml", line 25, characters 2-43:
-Warning 59: A potential assignment to a non-mutable value was detected
-in this source file. Such assignments may generate incorrect code
-when using Flambda.
-File "w59.opt_backend.ml", line 26, characters 2-43:
-Warning 59: A potential assignment to a non-mutable value was detected
-in this source file. Such assignments may generate incorrect code
-when using Flambda.
-File "w59.opt_backend.ml", line 27, characters 2-43:
-Warning 59: A potential assignment to a non-mutable value was detected
-in this source file. Such assignments may generate incorrect code
-when using Flambda.
-File "w59.opt_backend.ml", line 28, characters 2-43:
-Warning 59: A potential assignment to a non-mutable value was detected
-in this source file. Such assignments may generate incorrect code
-when using Flambda.
-File "w59.opt_backend.ml", line 35, characters 2-7:
-Warning 59: A potential assignment to a non-mutable value was detected
-in this source file. Such assignments may generate incorrect code
-when using Flambda.
+++ /dev/null
-
-(* Check that the warning 59 (assignment to immutable value) does not
- trigger on those examples *)
-let a = Lazy.force (lazy "a")
-let b = Lazy.force (lazy 1)
-let c = Lazy.force (lazy 3.14)
-let d = Lazy.force (lazy 'a')
-let e = Lazy.force (lazy (fun x -> x+1))
-let rec f (x:int) : int = g x and g x = f x
-let h = Lazy.force (lazy f)
-let i = Lazy.force (lazy g)
-let j = Lazy.force (lazy 1L)
-let k = Lazy.force (lazy (1,2))
-let l = Lazy.force (lazy [|3.14|])
-let m = Lazy.force (lazy (Sys.opaque_identity 3.14))
-let n = Lazy.force (lazy None)
-
-(* Check that obviously wrong code is reported *)
-let o = (1,2)
-let p = fun x -> x
-let q = 3.14
-let r = 1
-
-let () =
- Obj.set_field (Obj.repr o) 0 (Obj.repr 3);
- Obj.set_field (Obj.repr p) 0 (Obj.repr 3);
- Obj.set_field (Obj.repr q) 0 (Obj.repr 3);
- Obj.set_field (Obj.repr r) 0 (Obj.repr 3)
-
-let set v =
- Obj.set_field (Obj.repr v) 0 (Obj.repr 3)
- [@@inline]
-
-let () =
- set o
-
-(* Sys.opaque_identity hide all information and shouldn't warn *)
-
-let opaque = Sys.opaque_identity (1,2)
-let set_opaque =
- Obj.set_field
- (Obj.repr opaque)
- 0
- (Obj.repr 3)
+(* TEST
+
+flags = "-w A"
+
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+compile_only = "true"
+*** check-ocamlc.byte-output
+
+*)
+
(* PR#7314 *)
module type Comparable = sig
GENERATED_SOURCES=symlink_tests.precheck
+ifeq ($(CCOMPTYPE),msvc)
+CCOMP=set -o pipefail ; $(CC) $(CFLAGS) $(CPPFLAGS) /Fe$(1) $(addprefix /link ,$(LDFLAGS)) | tail -n +2
+else
+CCOMP=$(CC) $(CFLAGS) $(CPPFLAGS) $(LDFLAGS) -o $(1)
+endif
+
%.exe: %.c
- @$(CC) $(CFLAGS) $(CPPFLAGS) $(LDFLAGS) $(if $(filter msvc,$(CCOMPTYPE)),/Fe$*.exe,-o$*.exe) $*.c
+ @$(call CCOMP,$*.exe $*.c)
../../compilerlibs/ocamlbytecomp \
../../compilerlibs/ocamltoplevel
-$(PROG): $(MAIN).cmo
+$(PROG): $(MAIN).cmo $(LIBRARIES:=.cma)
$(OCAMLC) -linkall -o $(PROG) $(LIBRARIES:=.cma) $(MAIN).cmo
include $(BASEDIR)/makefiles/Makefile.common
module Compiler_messages = struct
let print_loc ppf (loc : Location.t) =
let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in
- let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
+ let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_bol in
Format.fprintf ppf "Line _";
if startchar >= 0 then
Format.fprintf ppf ", characters %d-%d" startchar endchar;
- Format.fprintf ppf ":@,"
+ Format.fprintf ppf ":@.";
+ if startchar >= 0 then
+ begin match !Location.input_lexbuf with
+ | None -> ()
+ | Some lexbuf ->
+ Location.show_code_at_location ppf lexbuf loc
+ end;
+ ()
let capture ppf ~f =
Misc.protect_refs
let lexbuf = Lexing.from_string contents in
Location.init lexbuf fname;
Location.input_name := fname;
+ Location.input_lexbuf := Some lexbuf;
Parse.use_file lexbuf
let eval_expectation expectation ~output =
try
exec_phrase ppf phrase
with exn ->
- Location.report_exception ppf exn;
- false)
+ let bt = Printexc.get_raw_backtrace () in
+ begin try Location.report_exception ppf exn
+ with _ ->
+ Format.fprintf ppf "Uncaught exception: %s\n%s\n"
+ (Printexc.to_string exn)
+ (Printexc.raw_backtrace_to_string bt)
+ end;
+ false
+ )
in
Format.pp_print_flush ppf ();
let len = Buffer.length buf in
let correction = eval_expect_file fname ~file_contents in
write_corrected ~file:corrected_fname ~file_contents correction
-let repo_root = ref ""
+let repo_root = ref None
let main fname =
Toploop.override_sys_argv
~len:(Array.length Sys.argv - !Arg.current));
(* Ignore OCAMLRUNPARAM=b to be reproducible *)
Printexc.record_backtrace false;
- List.iter [ "stdlib" ] ~f:(fun s ->
- Topdirs.dir_directory (Filename.concat !repo_root s));
+ if not !Clflags.no_std_include then begin
+ match !repo_root with
+ | None -> ()
+ | Some dir ->
+ (* If we pass [-repo-root], use the stdlib from inside the
+ compiler, not the installed one. We use
+ [Compenv.last_include_dirs] to make sure that the stdlib
+ directory is the last one. *)
+ Clflags.no_std_include := true;
+ Compenv.last_include_dirs := [Filename.concat dir "stdlib"]
+ end;
+ Compmisc.init_path false;
Toploop.initialize_toplevel_env ();
Sys.interactive := false;
process_expect_file fname;
exit 0
+module Options = Main_args.Make_bytetop_options (struct
+ let set r () = r := true
+ let clear r () = r := false
+ open Clflags
+ let _absname = set Location.absname
+ let _I dir =
+ let dir = Misc.expand_directory Config.standard_library dir in
+ include_dirs := dir :: !include_dirs
+ let _init s = init_file := Some s
+ let _noinit = set noinit
+ let _labels = clear classic
+ let _alias_deps = clear transparent_modules
+ let _no_alias_deps = set transparent_modules
+ let _app_funct = set applicative_functors
+ let _no_app_funct = clear applicative_functors
+ let _noassert = set noassert
+ let _nolabels = set classic
+ let _noprompt = set noprompt
+ let _nopromptcont = set nopromptcont
+ let _nostdlib = set no_std_include
+ let _open s = open_modules := s :: !open_modules
+ let _ppx _s = (* disabled *) ()
+ let _principal = set principal
+ let _no_principal = clear principal
+ let _rectypes = set recursive_types
+ let _no_rectypes = clear recursive_types
+ let _safe_string = clear unsafe_string
+ let _short_paths = clear real_paths
+ let _stdin () = (* disabled *) ()
+ let _strict_sequence = set strict_sequence
+ let _no_strict_sequence = clear strict_sequence
+ let _strict_formats = set strict_formats
+ let _no_strict_formats = clear strict_formats
+ let _unboxed_types = set unboxed_types
+ let _no_unboxed_types = clear unboxed_types
+ let _unsafe = set fast
+ let _unsafe_string = set unsafe_string
+ let _version () = (* disabled *) ()
+ let _vnum () = (* disabled *) ()
+ let _no_version = set noversion
+ let _w s = Warnings.parse_options false s
+ let _warn_error s = Warnings.parse_options true s
+ let _warn_help = Warnings.help_warnings
+ let _dparsetree = set dump_parsetree
+ let _dtypedtree = set dump_typedtree
+ let _dno_unique_ids = clear unique_ids
+ let _dunique_ids = set unique_ids
+ let _dsource = set dump_source
+ let _drawlambda = set dump_rawlambda
+ let _dlambda = set dump_lambda
+ let _dflambda = set dump_flambda
+ let _dtimings () = profile_columns := [ `Time ]
+ let _dprofile () = profile_columns := Profile.all_columns
+ let _dinstr = set dump_instr
+
+ let _args = Arg.read_arg
+ let _args0 = Arg.read_arg0
+
+ let anonymous s = main s
+end);;
+
let args =
Arg.align
- [ "-repo-root", Set_string repo_root,
- "<dir> root of the OCaml repository"
- ; "-principal", Set Clflags.principal,
- " Evaluate the file with -principal set"
- ]
+ ( [ "-repo-root", Arg.String (fun s -> repo_root := Some s),
+ "<dir> root of the OCaml repository. This causes the tool to use \
+ the stdlib from the current source tree rather than the installed one."
+ ] @ Options.list
+ )
let usage = "Usage: expect_test <options> [script-file [arguments]]\n\
options are:"
let () =
+ Clflags.color := Some Misc.Color.Never;
Clflags.error_size := 0;
try
Arg.parse args main usage;
MAKEFLAGS := -r -R
include ../config/Makefile
-INSTALL_BINDIR:=$(DESTDIR)$(BINDIR)
-INSTALL_LIBDIR:=$(DESTDIR)$(LIBDIR)
-INSTALL_COMPLIBDIR:=$(DESTDIR)$(COMPLIBDIR)
-INSTALL_STUBLIBDIR:=$(DESTDIR)$(STUBLIBDIR)
-INSTALL_MANDIR:=$(DESTDIR)$(MANDIR)
+include ../Makefile.common
ifeq ($(SYSTEM),unix)
override define shellquote
$i := $$(subst ",\",$$(subst $$$$,\$$$$,$$(subst `,\`,$i)))#")#
endef
-$(foreach i,BINDIR LIBDIR COMPLIBDIR STUBLIBDIR MANDIR,$(eval $(shellquote)))
+$(foreach i,BINDIR LIBDIR STUBLIBDIR MANDIR,$(eval $(shellquote)))
endif
CAMLRUN ?= ../boot/ocamlrun
CSLPROF=ocamlprof.cmo
CSLPROF_IMPORTS=misc.cmo config.cmo identifiable.cmo numbers.cmo \
arg_helper.cmo clflags.cmo terminfo.cmo \
+ build_path_prefix_map.cmo \
warnings.cmo location.cmo longident.cmo docstrings.cmo \
syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo
opt:: profiling.cmx
install::
- cp -- profiling.cmi profiling.cmo profiling.cmt profiling.cmti "$(INSTALL_LIBDIR)"
+ $(INSTALL_DATA) \
+ profiling.cmi profiling.cmo profiling.cmt profiling.cmti \
+ "$(INSTALL_LIBDIR)"
installopt::
- cp -- profiling.cmx profiling.$(O) "$(INSTALL_LIBDIR)"
+ $(INSTALL_DATA) \
+ profiling.cmx profiling.$(O) \
+ "$(INSTALL_LIBDIR)"
# To help building mixed-mode libraries (OCaml + C)
# Converter olabl/ocaml 2.99 to ocaml 3
OCAML299TO3= lexer299.cmo ocaml299to3.cmo
-LIBRARY3= misc.cmo warnings.cmo location.cmo
+LIBRARY3= misc.cmo warnings.cmo build_path_prefix_map.cmo location.cmo
ocaml299to3: $(OCAML299TO3)
$(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3)
$(CAMLLEX) lexer299.mll
#install::
-# cp ocaml299to3 "$(INSTALL_BINDIR)/ocaml299to3$(EXE)"
+# $(INSTALL_PROG) ocaml299to3 "$(INSTALL_BINDIR)/ocaml299to3$(EXE)"
clean::
rm -f ocaml299to3 lexer299.ml
$(CAMLLEX) lexer301.mll
#install::
-# cp scrapelabels "$(INSTALL_LIBDIR)"
+# $(INSTALL_PROG) scrapelabels "$(INSTALL_LIBDIR)"
clean::
rm -f scrapelabels lexer301.ml
ADDLABELS_IMPORTS=misc.cmo config.cmo arg_helper.cmo clflags.cmo \
identifiable.cmo numbers.cmo terminfo.cmo \
+ build_path_prefix_map.cmo \
warnings.cmo location.cmo longident.cmo docstrings.cmo \
syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo
$(ADDLABELS_IMPORTS) addlabels.cmo
#install::
-# cp addlabels "$(INSTALL_LIBDIR)"
+# $(INSTALL_PROG) addlabels "$(INSTALL_LIBDIR)"
ifeq ($(UNIX_OR_WIN32),unix)
LN := ln -sf
install::
for i in $(install_files); \
do \
- cp -- "$$i" "$(INSTALL_BINDIR)/$$i.byte$(EXE)" && \
+ $(INSTALL_PROG) "$$i" "$(INSTALL_BINDIR)/$$i.byte$(EXE)" && \
if test -f "$$i".opt; then \
- cp -- "$$i.opt" "$(INSTALL_BINDIR)/$$i.opt$(EXE)" && \
+ $(INSTALL_PROG) "$$i.opt" "$(INSTALL_BINDIR)/$$i.opt$(EXE)" && \
(cd "$(INSTALL_BINDIR)/" && $(LN) "$$i.opt$(EXE)" "$$i$(EXE)"); \
else \
(cd "$(INSTALL_BINDIR)/" && $(LN) "$$i.byte$(EXE)" "$$i$(EXE)"); \
install::
if test -f read_cmt.opt; then \
- cp read_cmt.opt "$(INSTALL_BINDIR)/ocamlcmt$(EXE)"; \
+ $(INSTALL_PROG) read_cmt.opt "$(INSTALL_BINDIR)/ocamlcmt$(EXE)"; \
else \
- cp read_cmt "$(INSTALL_BINDIR)/ocamlcmt$(EXE)"; \
+ $(INSTALL_PROG) read_cmt "$(INSTALL_BINDIR)/ocamlcmt$(EXE)"; \
fi
DUMPOBJ=opnames.cmo dumpobj.cmo
-$(call byte_and_opt,dumpobj,misc.cmo identifiable.cmo numbers.cmo tbl.cmo \
- config.cmo ident.cmo opcodes.cmo bytesections.cmo \
- $(DUMPOBJ),)
+$(call byte_and_opt,dumpobj,misc.cmo config.cmo identifiable.cmo \
+ numbers.cmo arg_helper.cmo clflags.cmo tbl.cmo \
+ ident.cmo opcodes.cmo bytesections.cmo $(DUMPOBJ),)
make_opcodes.ml: make_opcodes.mll
$(CAMLLEX) make_opcodes.mll
$(call byte_and_opt,ocamlobjinfo,$(OBJINFO),objinfo_helper$(EXE))
install::
- cp objinfo_helper$(EXE) "$(INSTALL_LIBDIR)/objinfo_helper$(EXE)"
+ $(INSTALL_PROG) \
+ objinfo_helper$(EXE) "$(INSTALL_LIBDIR)/objinfo_helper$(EXE)"
# Scan object files for required primitives
$(call byte_and_opt,primreq,config.cmo primreq.cmo,)
ifeq "$(RUNTIMEI)" "true"
install::
- cp ocaml-instr-graph ocaml-instr-report "$(INSTALL_BINDIR)/"
+ $(INSTALL_PROG) \
+ ocaml-instr-graph ocaml-instr-report \
+ "$(INSTALL_BINDIR)/"
endif
# Common stuff
+++ /dev/null
-#!/bin/sh
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Damien Doligez, projet Gallium, INRIA Rocquencourt *
-#* *
-#* Copyright 2014 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-# This script is run on our continuous-integration servers to recompile
-# from scratch and run the test suite.
-
-# To know the slave's architecture, this script looks at the OCAML_ARCH
-# environment variable. For a given node NODe, this variable can be defined
-# in Jenkins at the following address:
-# https://ci.inria.fr/ocaml/computer/NODE/configure
-
-# Other environments variables that are honored:
-# OCAML_CONFIGURE_OPTIONS additional options for configure
-# OCAML_JOBS number of jobs to run in parallel (make -j)
-
-# Command-line arguments:
-# -conf configure-option add configure-option to configure cmd line
-# -patch1 file-name apply patch with -p1
-# -no-native do not build "opt" and "opt.opt"
-# -jNN pass "-jNN" option to make for parallel builds
-
-error () {
- echo "$1" >&2
- exit 3
-}
-
-arch_error() {
- configure_url="https://ci.inria.fr/ocaml/computer/${NODE_NAME}/configure"
- msg="Unknown architecture. Make sure the OCAML_ARCH environemnt"
- msg="$msg variable has been defined."
- msg="$msg\nSee ${configure_url}"
- error "$msg"
-}
-
-# Kill a task on Windows
-# Errors are ignored
-kill_task()
-{
- task=$1
- taskkill /f /im ${task} || true
-}
-
-quote1 () {
- printf "'%s'" "`printf %s "$1" | sed -e "s/'/'\\\\\\\\''/g"`";
-}
-
-#########################################################################
-# be verbose
-set -x
-
-#########################################################################
-# Save the current directory (on cygwin, /etc/profile changes it)
-jenkinsdir="$(pwd)"
-echo jenkinsdir=${jenkinsdir}
-
-#########################################################################
-# If we are called from a Windows batch script, we must set up the
-# Unix environment variables (e.g. PATH).
-
-case "${OCAML_ARCH}" in
- bsd|macos|linux) ;;
- cygwin|mingw|mingw64)
- . /etc/profile
- . "$HOME/.profile"
- ;;
- msvc)
- . /etc/profile
- . "$HOME/.profile"
- . "$HOME/.msenv32"
- ;;
- msvc64)
- . /etc/profile
- . "$HOME/.profile"
- . "$HOME/.msenv64"
- ;;
- *) arch_error;;
-esac
-
-#########################################################################
-
-# be considerate towards other potential users of the test machine
-case "${OCAML_ARCH}" in
- bsd|macos|linux) renice 10 $$ ;;
-esac
-
-# be verbose and stop on error
-set -ex
-
-#########################################################################
-# set up variables
-
-# default values
-make=make
-instdir="$HOME/ocaml-tmp-install"
-configure=unix
-confoptions="${OCAML_CONFIGURE_OPTIONS}"
-make_native=true
-cleanup=false
-check_make_alldepend=false
-dorebase=false
-jobs=''
-
-case "${OCAML_ARCH}" in
- bsd) make=gmake ;;
- macos) ;;
- linux)
- confoptions="${confoptions} -with-instrumented-runtime"
- check_make_alldepend=true
- ;;
- cygwin)
- cleanup=true
- check_make_alldepend=true
- dorebase=true
- ;;
- mingw)
- instdir='C:/ocamlmgw'
- configure=nt
- cleanup=true
- check_make_alldepend=true
- ;;
- mingw64)
- instdir='C:/ocamlmgw64'
- configure=nt
- cleanup=true
- check_make_alldepend=true
- ;;
- msvc)
- instdir='C:/ocamlms'
- configure=nt
- cleanup=true
- ;;
- msvc64)
- instdir='C:/ocamlms64'
- configure=nt
- cleanup=true
- ;;
- *) arch_error;;
-esac
-
-# Make sure two builds won't use the same install directory
-instdir="$instdir-$$"
-
-case "${OCAML_JOBS}" in
- [1-9]|[1-9][0-9]) jobs="-j${OCAML_JOBS}" ;;
-esac
-
-#########################################################################
-# On Windows, cleanup processes that may remain from previous run
-
-if $cleanup; then
- tasks="tee ocamlrun program"
- for task in ${tasks}; do kill_task ${task}.exe; done
-fi
-
-#########################################################################
-# Go to the right directory
-
-pwd
-cd "$jenkinsdir"
-
-#########################################################################
-# parse optional command-line arguments (has to be done after the "cd")
-
-while [ $# -gt 0 ]; do
- case $1 in
- -conf) confoptions="$confoptions `quote1 "$2"`"; shift;;
- -patch1) patch -f -p1 <"$2"; shift;;
- -no-native) make_native=false;;
- -j[1-9]|-j[1-9][0-9]) jobs="$1";;
- *) error "unknown option $1";;
- esac
- shift
-done
-
-#########################################################################
-# Do the work
-
-# Tell gcc to use only ASCII in its diagnostic outputs.
-export LC_ALL=C
-
-$make -s distclean || :
-
-# `make distclean` does not clean the files from previous versions that
-# are not produced by the current version, so use `git clean` in addition.
-git clean -f -d -x
-
-case $configure in
- unix)
- confoptions="$confoptions -with-debug-runtime"
- if $flambda; then
- confoptions="$confoptions -flambda"
- fi
- eval "./configure -prefix '$instdir' $confoptions"
- ;;
- nt)
- cp config/m-nt.h byterun/caml/m.h
- cp config/s-nt.h byterun/caml/s.h
- cp config/Makefile.${OCAML_ARCH} config/Makefile
- sed -i "s%PREFIX=\(.\+\)%PREFIX=${instdir}%" config/Makefile
- sed -i 's%RUNTIMED=.\+%RUNTIMED=true%' config/Makefile
- if $flambda; then
- sed -i 's%FLAMBDA=.\+%FLAMBDA=true%' config/Makefile
- fi
- ;;
- *) error "internal error";;
-esac
-
-$make $jobs coldstart
-$make $jobs core
-$make $jobs coreboot
-$make $jobs world
-if $make_native; then
- $make $jobs opt
- $make $jobs opt.opt
- if $check_make_alldepend; then $make alldepend; fi
-fi
-if $dorebase; then
- # temporary solution to the cygwin fork problem
- rebase -b 0x7cd20000 otherlibs/unix/dllunix.so
- rebase -b 0x7cdc0000 otherlibs/systhreads/dllthreads.so
-fi
-$make install
-
-rm -rf "$instdir"
-cd testsuite
-$make all
+++ /dev/null
-#!/bin/sh
-#**************************************************************************
-#* *
-#* OCaml *
-#* *
-#* Sebastien Hinderer, projet Gallium, INRIA Paris *
-#* *
-#* Copyright 2017 Institut National de Recherche en Informatique et *
-#* en Automatique. *
-#* *
-#* All rights reserved. This file is distributed under the terms of *
-#* the GNU Lesser General Public License version 2.1, with the *
-#* special exception on linking described in the file LICENSE. *
-#* *
-#**************************************************************************
-
-# Commands to run for the 'other-configs' job on Inria's CI
-
-./tools/ci-build -conf -no-native-compiler -no-native
-./tools/ci-build -conf -no-naked-pointers
-./tools/ci-build -conf -flambda -conf -no-naked-pointers
--- /dev/null
+@rem ***********************************************************************
+@rem * *
+@rem * OCaml *
+@rem * *
+@rem * David Allsopp, OCaml Labs, Cambridge. *
+@rem * *
+@rem * Copyright 2017 MetaStack Solutions Ltd. *
+@rem * *
+@rem * All rights reserved. This file is distributed under the terms of *
+@rem * the GNU Lesser General Public License version 2.1, with the *
+@rem * special exception on linking described in the file LICENSE. *
+@rem * *
+@rem ***********************************************************************
+
+@rem BE CAREFUL ALTERING THIS FILE TO ENSURE THAT ERRORS PROPAGATE
+@rem IF A COMMAND SHOULD FAIL IT PROBABLY NEEDS TO END WITH
+@rem || exit /b 1
+@rem BASICALLY, DO THE TESTING IN BASH...
+
+@rem Do not call setlocal!
+@echo off
+
+goto %1
+
+goto :EOF
+
+:SaveVars
+set OCAML_PREV_PATH=%PATH%
+set OCAML_PREV_LIB=%LIB%
+set OCAML_PREV_INCLUDE=%INCLUDE%
+goto :EOF
+
+:RestoreVars
+set PATH=%OCAML_PREV_PATH%
+set LIB=%OCAML_PREV_LIB%
+set INCLUDE=%OCAML_PREV_INCLUDE%
+goto :EOF
+
+:CheckPackage
+"%CYG_ROOT%\bin\bash.exe" -lc "cygcheck -dc %1" | findstr %1 > nul
+if %ERRORLEVEL% equ 1 (
+ echo Cygwin package %1 will be installed
+ set CYGWIN_INSTALL_PACKAGES=%CYGWIN_INSTALL_PACKAGES%,%1
+)
+goto :EOF
+
+:UpgradeCygwin
+if "%CYGWIN_INSTALL_PACKAGES%" neq "" "%CYG_ROOT%\setup-x86_64.exe" --quiet-mode --no-shortcuts --no-startmenu --no-desktop --only-site --root "%CYG_ROOT%" --site "%CYG_MIRROR%" --local-package-dir "%CYG_CACHE%" --packages %CYGWIN_INSTALL_PACKAGES:~1% > nul
+for %%P in (%CYGWIN_COMMANDS%) do "%CYG_ROOT%\bin\%%P.exe" --version > nul || set CYGWIN_UPGRADE_REQUIRED=1
+"%CYG_ROOT%\bin\bash.exe" -lc "cygcheck -dc %CYGWIN_PACKAGES%"
+if %CYGWIN_UPGRADE_REQUIRED% equ 1 (
+ echo Cygwin package upgrade required - please go and drink coffee
+ "%CYG_ROOT%\setup-x86_64.exe" --quiet-mode --no-shortcuts --no-startmenu --no-desktop --only-site --root "%CYG_ROOT%" --site "%CYG_MIRROR%" --local-package-dir "%CYG_CACHE%" --upgrade-also > nul
+ "%CYG_ROOT%\bin\bash.exe" -lc "cygcheck -dc %CYGWIN_PACKAGES%"
+)
+goto :EOF
+
+:install
+chcp 65001 > nul
+rem This must be kept in sync with appveyor_build.sh
+set BUILD_PREFIX=🐫реализация
+git worktree add "..\%BUILD_PREFIX%-msvc64" -b appveyor-build-msvc64
+git worktree add "..\%BUILD_PREFIX%-mingw32" -b appveyor-build-mingw32
+git worktree add "..\%BUILD_PREFIX%-msvc32" -b appveyor-build-msvc32
+cd "..\%BUILD_PREFIX%-mingw32"
+git submodule update --init flexdll
+
+cd "%APPVEYOR_BUILD_FOLDER%"
+appveyor DownloadFile "https://github.com/alainfrisch/flexdll/archive/0.37.tar.gz" -FileName "flexdll.tar.gz" || exit /b 1
+appveyor DownloadFile "https://github.com/alainfrisch/flexdll/releases/download/0.37/flexdll-bin-0.37.zip" -FileName "flexdll.zip" || exit /b 1
+rem flexdll.zip is processed here, rather than in appveyor_build.sh because the
+rem unzip command comes from MSYS2 (via Git for Windows) and it has to be
+rem invoked via cmd /c in a bash script which is weird(er).
+mkdir "%APPVEYOR_BUILD_FOLDER%\..\flexdll"
+move flexdll.zip "%APPVEYOR_BUILD_FOLDER%\..\flexdll"
+cd "%APPVEYOR_BUILD_FOLDER%\..\flexdll" && unzip -q flexdll.zip
+
+rem CYGWIN_PACKAGES is the list of required Cygwin packages (cygwin is included
+rem in the list just so that the Cygwin version is always displayed on the log).
+rem CYGWIN_COMMANDS is a corresponding command to run with --version to test
+rem whether the package works. This is used to verify whether the installation
+rem needs upgrading.
+set CYGWIN_PACKAGES=cygwin make diffutils mingw64-i686-gcc-core
+set CYGWIN_COMMANDS=cygcheck make diff i686-w64-mingw32-gcc
+
+set CYGWIN_INSTALL_PACKAGES=
+set CYGWIN_UPGRADE_REQUIRED=0
+
+for %%P in (%CYGWIN_PACKAGES%) do call :CheckPackage %%P
+call :UpgradeCygwin
+
+"%CYG_ROOT%\bin\bash.exe" -lec "$APPVEYOR_BUILD_FOLDER/tools/ci/appveyor/appveyor_build.sh install" || exit /b 1
+
+call :SaveVars
+goto :EOF
+
+:build
+rem Run the msvc64 and mingw32 builds
+call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat"
+"%CYG_ROOT%\bin\bash.exe" -lec "$APPVEYOR_BUILD_FOLDER/tools/ci/appveyor/appveyor_build.sh" || exit /b 1
+
+rem Reconfigure the environment and run the msvc32 partial build
+call :RestoreVars
+call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x86
+"%CYG_ROOT%\bin\bash.exe" -lec "$APPVEYOR_BUILD_FOLDER/tools/ci/appveyor/appveyor_build.sh msvc32-only" || exit /b 1
+goto :EOF
+
+:test
+rem Reconfigure the environment for the msvc64 build
+call :RestoreVars
+call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat"
+"%CYG_ROOT%\bin\bash.exe" -lec "$APPVEYOR_BUILD_FOLDER/tools/ci/appveyor/appveyor_build.sh test" || exit /b 1
+goto :EOF
--- /dev/null
+#!/bin/bash
+#**************************************************************************
+#* *
+#* OCaml *
+#* *
+#* Christophe Troestler *
+#* *
+#* Copyright 2015 Christophe Troestler *
+#* *
+#* All rights reserved. This file is distributed under the terms of *
+#* the GNU Lesser General Public License version 2.1, with the *
+#* special exception on linking described in the file LICENSE. *
+#* *
+#**************************************************************************
+
+BUILD_PID=0
+
+function run {
+ NAME=$1
+ shift
+ echo "-=-=- $NAME -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-"
+ $@
+ CODE=$?
+ if [ $CODE -ne 0 ]; then
+ echo "-=-=- $NAME failed! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-"
+ if [ $BUILD_PID -ne 0 ] ; then
+ kill -KILL $BUILD_PID 2>/dev/null
+ wait $BUILD_PID 2>/dev/null
+ fi
+ exit $CODE
+ else
+ echo "-=-=- End of $NAME -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-"
+ fi
+}
+
+function set_configuration {
+ cp config/m-nt.h byterun/caml/m.h
+ cp config/s-nt.h byterun/caml/s.h
+
+ FILE=$(pwd | cygpath -f - -m)/config/Makefile
+ echo "Edit $FILE to set PREFIX=$2"
+ sed -e "/PREFIX=/s|=.*|=$2|" \
+ -e "/^ *CFLAGS *=/s/\r\?$/ $3\0/" \
+ config/Makefile.$1 > config/Makefile
+# run "Content of $FILE" cat config/Makefile
+}
+
+APPVEYOR_BUILD_FOLDER=$(echo $APPVEYOR_BUILD_FOLDER| cygpath -f -)
+# These directory names are specified here, because getting UTF-8 correctly
+# through appveyor.yml -> Command Script -> Bash is quite painful...
+OCAMLROOT=$(echo $PROGRAMFILES/Бактріан🐫| cygpath -f - -m)
+
+# This must be kept in sync with appveyor_build.cmd
+BUILD_PREFIX=🐫реализация
+
+export PATH=$(echo $OCAMLROOT| cygpath -f -)/bin/flexdll:$PATH
+
+case "$1" in
+ install)
+ mkdir -p "$OCAMLROOT/bin/flexdll"
+ cd $APPVEYOR_BUILD_FOLDER/../flexdll
+ # msvc64 objects need to be compiled with VS2015, so are copied later from
+ # a source build.
+ for f in flexdll.h flexlink.exe flexdll*_msvc.obj default*.manifest ; do
+ cp $f "$OCAMLROOT/bin/flexdll/"
+ done
+ echo 'eval $($APPVEYOR_BUILD_FOLDER/tools/msvs-promote-path)' >> ~/.bash_profile
+ ;;
+ msvc32-only)
+ cd $APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX-msvc32
+
+ set_configuration msvc "$OCAMLROOT-msvc32" -WX
+
+ run "make world" make world
+ run "make runtimeopt" make runtimeopt
+ run "make -C otherlibs/systhreads libthreadsnat.lib" \
+ make -C otherlibs/systhreads libthreadsnat.lib
+
+ exit 0
+ ;;
+ test)
+ FULL_BUILD_PREFIX=$APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX
+ run "ocamlc.opt -version" $FULL_BUILD_PREFIX-msvc64/ocamlc.opt -version
+ run "test msvc64" make -C $FULL_BUILD_PREFIX-msvc64 tests
+ run "test mingw32" make -C $FULL_BUILD_PREFIX-mingw32 tests
+ run "install msvc64" make -C $FULL_BUILD_PREFIX-msvc64 install
+ run "install mingw32" make -C $FULL_BUILD_PREFIX-mingw32 install
+ ;;
+ *)
+ cd $APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX-msvc64
+
+ tar -xzf $APPVEYOR_BUILD_FOLDER/flexdll.tar.gz
+ cd flexdll-$FLEXDLL_VERSION
+ make MSVC_DETECT=0 CHAINS=msvc64 support
+ cp flexdll*_msvc64.obj "$OCAMLROOT/bin/flexdll/"
+ cd ..
+
+ set_configuration msvc64 "$OCAMLROOT" -WX
+
+ cd ../$BUILD_PREFIX-mingw32
+
+ set_configuration mingw "$OCAMLROOT-mingw32" -Werror
+
+ cd $APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX-msvc64
+
+ export TERM=ansi
+ script --quiet --return --command "make -C ../$BUILD_PREFIX-mingw32 flexdll world.opt" ../$BUILD_PREFIX-mingw32/build.log >/dev/null 2>/dev/null &
+ BUILD_PID=$!
+
+ run "make world" make world
+ run "make bootstrap" make bootstrap
+ run "make opt" make opt
+ run "make opt.opt" make opt.opt
+
+ set +e
+
+ # For an explanation of the sed command, see https://github.com/appveyor/ci/issues/1824
+ tail --pid=$BUILD_PID -n +1 -f ../$BUILD_PREFIX-mingw32/build.log | sed -e 's/\d027\[K//g' -e 's/\d027\[m/\d027[0m/g' -e 's/\d027\[01\([m;]\)/\d027[1\1/g' &
+ TAIL_PID=$!
+ wait $BUILD_PID
+ STATUS=$?
+ wait $TAIL_PID
+ exit $STATUS
+ ;;
+esac
--- /dev/null
+#!/bin/sh
+#**************************************************************************
+#* *
+#* OCaml *
+#* *
+#* Damien Doligez, projet Gallium, INRIA Rocquencourt *
+#* *
+#* Copyright 2014 Institut National de Recherche en Informatique et *
+#* en Automatique. *
+#* *
+#* All rights reserved. This file is distributed under the terms of *
+#* the GNU Lesser General Public License version 2.1, with the *
+#* special exception on linking described in the file LICENSE. *
+#* *
+#**************************************************************************
+
+# This script is run on our continuous-integration servers to recompile
+# from scratch and run the test suite.
+
+# To know the slave's architecture, this script looks at the OCAML_ARCH
+# environment variable. For a given node NODe, this variable can be defined
+# in Jenkins at the following address:
+# https://ci.inria.fr/ocaml/computer/NODE/configure
+
+# Other environments variables that are honored:
+# OCAML_CONFIGURE_OPTIONS additional options for configure
+# OCAML_JOBS number of jobs to run in parallel (make -j)
+
+# Command-line arguments:
+# -conf configure-option add configure-option to configure cmd line
+# -patch1 file-name apply patch with -p1
+# -no-native do not build "opt" and "opt.opt"
+# -jNN pass "-jNN" option to make for parallel builds
+
+error () {
+ echo "$1" >&2
+ exit 3
+}
+
+arch_error() {
+ configure_url="https://ci.inria.fr/ocaml/computer/${NODE_NAME}/configure"
+ msg="Unknown architecture. Make sure the OCAML_ARCH environemnt"
+ msg="$msg variable has been defined."
+ msg="$msg\nSee ${configure_url}"
+ error "$msg"
+}
+
+# Kill a task on Windows
+# Errors are ignored
+kill_task()
+{
+ task=$1
+ taskkill /f /im ${task} /t || true
+}
+
+quote1 () {
+ printf "'%s'" "`printf %s "$1" | sed -e "s/'/'\\\\\\\\''/g"`";
+}
+
+#########################################################################
+# be verbose
+set -x
+
+#########################################################################
+# Save the current directory (on cygwin, /etc/profile changes it)
+jenkinsdir="$(pwd)"
+echo jenkinsdir=${jenkinsdir}
+
+#########################################################################
+# If we are called from a Windows batch script, we must set up the
+# Unix environment variables (e.g. PATH).
+
+case "${OCAML_ARCH}" in
+ bsd|macos|linux) ;;
+ cygwin|mingw|mingw64)
+ . /etc/profile
+ . "$HOME/.profile"
+ ;;
+ msvc)
+ . /etc/profile
+ . "$HOME/.profile"
+ . "$HOME/.msenv32"
+ ;;
+ msvc64)
+ . /etc/profile
+ . "$HOME/.profile"
+ . "$HOME/.msenv64"
+ ;;
+ *) arch_error;;
+esac
+
+#########################################################################
+
+# be considerate towards other potential users of the test machine
+case "${OCAML_ARCH}" in
+ bsd|macos|linux) renice 10 $$ ;;
+esac
+
+# be verbose and stop on error
+set -ex
+
+#########################################################################
+# set up variables
+
+# default values
+make=make
+instdir="$HOME/ocaml-tmp-install"
+configure=unix
+confoptions="${OCAML_CONFIGURE_OPTIONS}"
+make_native=true
+cleanup=false
+check_make_alldepend=false
+dorebase=false
+jobs=''
+
+case "${OCAML_ARCH}" in
+ bsd) make=gmake ;;
+ macos) ;;
+ linux)
+ confoptions="${confoptions} -with-instrumented-runtime"
+ check_make_alldepend=true
+ ;;
+ cygwin)
+ cleanup=true
+ check_make_alldepend=true
+ dorebase=true
+ ;;
+ mingw)
+ instdir='C:/ocamlmgw'
+ configure=nt
+ cleanup=true
+ check_make_alldepend=true
+ ;;
+ mingw64)
+ instdir='C:/ocamlmgw64'
+ configure=nt
+ cleanup=true
+ check_make_alldepend=true
+ ;;
+ msvc)
+ instdir='C:/ocamlms'
+ configure=nt
+ cleanup=true
+ ;;
+ msvc64)
+ instdir='C:/ocamlms64'
+ configure=nt
+ cleanup=true
+ ;;
+ *) arch_error;;
+esac
+
+# Make sure two builds won't use the same install directory
+instdir="$instdir-$$"
+
+case "${OCAML_JOBS}" in
+ [1-9]|[1-9][0-9]) jobs="-j${OCAML_JOBS}" ;;
+esac
+
+#########################################################################
+# On Windows, cleanup processes that may remain from previous run
+
+if $cleanup; then
+ tasks="tee ocamlrun program ocamltest ocamltest.opt"
+ for task in ${tasks}; do kill_task ${task}.exe; done
+fi
+
+#########################################################################
+# Go to the right directory
+
+pwd
+cd "$jenkinsdir"
+
+#########################################################################
+# parse optional command-line arguments (has to be done after the "cd")
+
+while [ $# -gt 0 ]; do
+ case $1 in
+ -conf) confoptions="$confoptions `quote1 "$2"`"; shift;;
+ -patch1) patch -f -p1 <"$2"; shift;;
+ -no-native) make_native=false;;
+ -j[1-9]|-j[1-9][0-9]) jobs="$1";;
+ *) error "unknown option $1";;
+ esac
+ shift
+done
+
+#########################################################################
+# Do the work
+
+# Tell gcc to use only ASCII in its diagnostic outputs.
+export LC_ALL=C
+
+$make -s distclean || :
+
+# `make distclean` does not clean the files from previous versions that
+# are not produced by the current version, so use `git clean` in addition.
+git clean -f -d -x
+
+case $configure in
+ unix)
+ confoptions="$confoptions -with-debug-runtime"
+ if $flambda; then
+ confoptions="$confoptions -flambda -with-flambda-invariants"
+ fi
+ eval "./configure -prefix '$instdir' $confoptions"
+ ;;
+ nt)
+ cp config/m-nt.h byterun/caml/m.h
+ cp config/s-nt.h byterun/caml/s.h
+ cp config/Makefile.${OCAML_ARCH} config/Makefile
+ sed -i "s%PREFIX=\(.\+\)%PREFIX=${instdir}%" config/Makefile
+ sed -i 's%RUNTIMED=.\+%RUNTIMED=true%' config/Makefile
+ if $flambda; then
+ sed -i 's%FLAMBDA=.\+%FLAMBDA=true%' config/Makefile
+ fi
+ ;;
+ *) error "internal error";;
+esac
+
+if $make_native; then
+ $make $jobs world.opt
+ if $check_make_alldepend; then $make alldepend; fi
+else
+ $make $jobs world
+fi
+if $dorebase; then
+ # temporary solution to the cygwin fork problem
+ # see https://github.com/alainfrisch/flexdll/issues/50
+ rebase -b 0x7cd20000 otherlibs/unix/dllunix.so
+ rebase -b 0x7cdc0000 otherlibs/systhreads/dllthreads.so
+fi
+$make install
+
+rm -rf "$instdir"
+cd testsuite
+if test -n "$jobs" && test -x /usr/bin/parallel
+then PARALLEL="$jobs $PARALLEL" $make parallel
+else $make all
+fi
--- /dev/null
+#!/bin/sh
+#**************************************************************************
+#* *
+#* OCaml *
+#* *
+#* Sebastien Hinderer, projet Gallium, INRIA Paris *
+#* *
+#* Copyright 2017 Institut National de Recherche en Informatique et *
+#* en Automatique. *
+#* *
+#* All rights reserved. This file is distributed under the terms of *
+#* the GNU Lesser General Public License version 2.1, with the *
+#* special exception on linking described in the file LICENSE. *
+#* *
+#**************************************************************************
+
+# Commands to run for the 'other-configs' job on Inria's CI
+
+# Stop on error
+set -e
+
+mainjob=./tools/ci/inria/main
+main="${mainjob} -j8"
+
+${main} -conf -no-native-compiler -no-native
+${main} -conf -no-naked-pointers
+${main} -conf -no-flat-float-array
+${main} -conf -flambda -conf -no-naked-pointers
+OCAMLRUNPARAM="c=1" ${main}
--- /dev/null
+#!/bin/bash
+#**************************************************************************
+#* *
+#* OCaml *
+#* *
+#* Anil Madhavapeddy, OCaml Labs *
+#* *
+#* Copyright 2014 Institut National de Recherche en Informatique et *
+#* en Automatique. *
+#* *
+#* All rights reserved. This file is distributed under the terms of *
+#* the GNU Lesser General Public License version 2.1, with the *
+#* special exception on linking described in the file LICENSE. *
+#* *
+#**************************************************************************
+
+PREFIX=~/local
+
+MAKE=make SHELL=dash
+
+# TRAVIS_COMMIT_RANGE has the form <commit1>...<commit2>
+# TRAVIS_CUR_HEAD is <commit1>
+# TRAVIS_PR_HEAD is <commit2>
+#
+# The following diagram illustrates the relationship between
+# the commits:
+#
+# (trunk) (pr branch)
+# TRAVIS_CUR_HEAD TRAVIS_PR_HEAD
+# | /
+# ... ...
+# | /
+# TRAVIS_MERGE_BASE
+#
+echo TRAVIS_COMMIT_RANGE=$TRAVIS_COMMIT_RANGE
+TRAVIS_CUR_HEAD=${TRAVIS_COMMIT_RANGE%%...*}
+TRAVIS_PR_HEAD=${TRAVIS_COMMIT_RANGE##*...}
+case $TRAVIS_EVENT_TYPE in
+ # If this is not a pull request then TRAVIS_COMMIT_RANGE may be empty.
+ pull_request)
+ TRAVIS_MERGE_BASE=$(git merge-base $TRAVIS_CUR_HEAD $TRAVIS_PR_HEAD);;
+esac
+
+BuildAndTest () {
+ mkdir -p $PREFIX
+ cat<<EOF
+------------------------------------------------------------------------
+This test builds the OCaml compiler distribution with your pull request
+and runs its testsuite.
+
+Failing to build the compiler distribution, or testsuite failures are
+critical errors that must be understood and fixed before your pull
+request can be merged.
+------------------------------------------------------------------------
+EOF
+ case $XARCH in
+ x64)
+ ./configure --prefix $PREFIX -with-debug-runtime \
+ -with-instrumented-runtime -with-flambda-invariants $CONFIG_ARG
+ ;;
+ i386)
+ ./configure --prefix $PREFIX -with-debug-runtime \
+ -with-instrumented-runtime -with-flambda-invariants $CONFIG_ARG \
+ -host i686-pc-linux-gnu
+ ;;
+ *)
+ echo unknown arch
+ exit 1
+ ;;
+ esac
+
+ export PATH=$PREFIX/bin:$PATH
+ $MAKE world.opt
+ $MAKE ocamlnat
+ cd testsuite
+ echo Running the testsuite with the normal runtime
+ $MAKE all
+ echo Running the testsuite with the debug runtime
+ $MAKE USE_RUNTIME="d" OCAMLTESTDIR=$(pwd)/_ocamltestd TESTLOG=_logd all
+ cd ..
+ $MAKE install
+ $MAKE manual-pregen
+ # check_all_arches checks tries to compile all backends in place,
+ # we would need to redo (small parts of) world.opt afterwards to
+ # use the compiler again
+ $MAKE check_all_arches
+ # check that the 'clean' target also works
+ $MAKE clean
+}
+
+CheckChangesModified () {
+ cat<<EOF
+------------------------------------------------------------------------
+This test checks that the Changes file has been modified by the pull
+request. Most contributions should come with a message in the Changes
+file, as described in our contributor documentation:
+
+ https://github.com/ocaml/ocaml/blob/trunk/CONTRIBUTING.md#changelog
+
+Some very minor changes (typo fixes for example) may not need
+a Changes entry. In this case, you may explicitly disable this test by
+adding the code word "No change entry needed" (on a single line) to
+a commit message of the PR, or using the "no-change-entry-needed" label
+on the github pull request.
+------------------------------------------------------------------------
+EOF
+ # check that Changes has been modified
+ git diff $TRAVIS_MERGE_BASE..$TRAVIS_PR_HEAD --name-only --exit-code Changes \
+ > /dev/null && CheckNoChangesMessage || echo pass
+}
+
+CheckNoChangesMessage () {
+ API_URL=https://api.github.com/repos/$TRAVIS_REPO_SLUG/issues/$TRAVIS_PULL_REQUEST/labels
+ if test -n "$(git log --grep="[Nn]o [Cc]hange.* needed" --max-count=1 \
+ ${TRAVIS_MERGE_BASE}..${TRAVIS_PR_HEAD})"
+ then echo pass
+ elif test -n "$(curl $API_URL | grep 'no-change-entry-needed')"
+ then echo pass
+ else exit 1
+ fi
+}
+
+CheckTestsuiteModified () {
+ cat<<EOF
+------------------------------------------------------------------------
+This test checks that the OCaml testsuite has been modified by the
+pull request. Any new feature should come with tests, bugs should come
+with regression tests, and generally any change in behavior that can
+be exercised by a test should come with a test or modify and existing
+test. See our contributor documentation:
+
+ https://github.com/ocaml/ocaml/blob/trunk/CONTRIBUTING.md#test-you-must
+
+Modifications that result in no change in observable behavior
+(documentation contributions for example) can hardly be tested, in
+which case it is acceptable for this test to fail.
+
+Note: the heuristic used by this test is extremely fragile; passing it
+does *not* imply that your change is appropriately tested.
+------------------------------------------------------------------------
+EOF
+ # check that at least a file in testsuite/ has been modified
+ git diff $TRAVIS_MERGE_BASE..$TRAVIS_PR_HEAD --name-only --exit-code \
+ testsuite > /dev/null && exit 1 || echo pass
+}
+
+case $CI_KIND in
+build) BuildAndTest;;
+changes)
+ case $TRAVIS_EVENT_TYPE in
+ pull_request) CheckChangesModified;;
+ esac;;
+tests)
+ case $TRAVIS_EVENT_TYPE in
+ pull_request) CheckTestsuiteModified;;
+ esac;;
+*) echo unknown CI kind
+ exit 1
+ ;;
+esac
opGETVECTITEM, Nothing;
opSETVECTITEM, Nothing;
opGETSTRINGCHAR, Nothing;
- opSETSTRINGCHAR, Nothing;
+ opGETBYTESCHAR, Nothing;
+ opSETBYTESCHAR, Nothing;
opBRANCH, Disp;
opBRANCHIF, Disp;
opBRANCHIFNOT, Disp;
esac
major="`echo "$version" | sed -n -e '1s/^\([0-9]*\)\..*/\1/p'`"
-minor="`echo "$version" | sed -n -e '1s/^[0-9]*\.\([0-9]*\).*/\1/p'`"
+minor="`echo "$version" | sed -n -e '1s/^[0-9]*\.0*\([0-9]*\).*/\1/p'`"
patchlvl="`echo "$version" | sed -n -e '1s/^[0-9]*\.[0-9]*\.\([0-9]*\).*/\1/p'`"
suffix="`echo "$version" | sed -n -e '1s/^[^+]*+\(.*\)/\1/p'`"
open Config
open Cmo_format
-(* Command line option to prevent printing approximation and function code *)
+(* Command line options to prevent printing approximation,
+ function code and CRC
+ *)
let no_approx = ref false
let no_code = ref false
+let no_crc = ref false
let input_stringlist ic len =
let get_string_list sect len =
get_string_list sect len
let dummy_crc = String.make 32 '-'
+let null_crc = String.make 32 '0'
+
+let string_of_crc crc = if !no_crc then null_crc else Digest.to_hex crc
let print_name_crc (name, crco) =
let crc =
match crco with
None -> dummy_crc
- | Some crc -> Digest.to_hex crc
+ | Some crc -> string_of_crc crc
in
printf "\t%s\t%s\n" crc name
printf "cmt interface digest: %s\n"
(match cmt.cmt_interface_digest with
| None -> ""
- | Some crc -> Digest.to_hex crc)
+ | Some crc -> string_of_crc crc)
let print_general_infos name crc defines cmi cmx =
printf "Name: %s\n" name;
- printf "CRC of implementation: %s\n" (Digest.to_hex crc);
+ printf "CRC of implementation: %s\n" (string_of_crc crc);
printf "Globals defined:\n";
List.iter print_line defines;
printf "Interfaces imported:\n";
Compilation_unit.set_current cu;
let root_symbols =
List.map (fun s ->
- Symbol.unsafe_create cu (Linkage_name.create ("caml"^s)))
+ Symbol.of_global_linkage cu (Linkage_name.create ("caml"^s)))
ui.ui_defines
in
Format.printf "approximations@ %a@.@."
let arg_list = [
"-no-approx", Arg.Set no_approx, " Do not print module approximation information";
"-no-code", Arg.Set no_code, " Do not print code from exported flambda functions";
+ "-null-crc", Arg.Set no_crc, " Print a null CRC for imported interfaces";
"-args", Arg.Expand Arg.read_arg,
"<file> Read additional newline separated command line arguments \n\
\ from <file>";
let _color s = option_with_arg "-color" s
let _where = option "-where"
let _nopervasives = option "-nopervasives"
+ let _dno_unique_ids = option "-dno-unique-ids"
+ let _dunique_ids = option "-dunique-ids"
let _dsource = option "-dsource"
let _dparsetree = option "-dparsetree"
let _dtypedtree = option "-dtypedtree"
let _linscan = option "-linscan"
let _nopervasives = option "-nopervasives"
+ let _dno_unique_ids = option "-dno-unique_ids"
+ let _dunique_ids = option "-dunique_ids"
let _dsource = option "-dsource"
let _dparsetree = option "-dparsetree"
let _dtypedtree = option "-dtypedtree"
let _dclambda = option "-dclambda"
let _drawflambda = option "-drawflambda"
let _dflambda = option "-dflambda"
+ let _dflambda_invariants = option "-dflambda-invariants"
let _dflambda_no_invariants = option "-dflambda-no-invariants"
let _dflambda_let stamp = option_with_int "-dflambda-let" stamp
let _dflambda_verbose = option "-dflambda-verbose"
let close_phrase lam =
let open Lambda in
- IdentSet.fold (fun id l ->
+ Ident.Set.fold (fun id l ->
let glb, pos = toplevel_value id in
let glob =
Lprim (Pfield pos,
else
Compilenv.record_global_approx_toplevel ();
if print_outcome then
- Printtyp.wrap_printing_env oldenv (fun () ->
+ Printtyp.wrap_printing_env ~error:false oldenv (fun () ->
match str.str_items with
| [] -> Ophr_signature []
| _ ->
let _dflambda_verbose () =
set dump_flambda ();
set dump_flambda_verbose ()
+ let _dflambda_invariants = set flambda_invariant_checks
let _dflambda_no_invariants = clear flambda_invariant_checks
let _labels = clear classic
let _alias_deps = clear transparent_modules
let _warn_error s = Warnings.parse_options true s
let _warn_help = Warnings.help_warnings
+ let _dno_unique_ids = clear unique_ids
+ let _dunique_ids = set unique_ids
let _dsource = set dump_source
let _dparsetree = set dump_parsetree
let _dtypedtree = set dump_typedtree
in
let id = Ident.create_persistent s in
let sg = to_sig env loc id lid in
- Printtyp.wrap_printing_env env
+ Printtyp.wrap_printing_env ~error:false env
(fun () -> fprintf ppf "@[%a@]@." Printtyp.signature sg)
with
| Not_found ->
match res with
| Result v ->
if print_outcome then
- Printtyp.wrap_printing_env oldenv (fun () ->
+ Printtyp.wrap_printing_env ~error:false oldenv (fun () ->
match str.str_items with
| [ { str_desc =
(Tstr_eval (exp, _)
let _warn_help = Warnings.help_warnings
let _dparsetree = set dump_parsetree
let _dtypedtree = set dump_typedtree
+ let _dno_unique_ids = clear unique_ids
+ let _dunique_ids = set unique_ids
let _dsource = set dump_source
let _drawlambda = set dump_rawlambda
let _dlambda = set dump_lambda
let new_id = ref (-1)
let newty2 level desc =
- incr new_id; { desc; level; id = !new_id }
+ incr new_id; { desc; level; scope = None; id = !new_id }
let newgenty desc = newty2 generic_level desc
let newgenvar ?name () = newgenty (Tvar name)
(*
Ctype of type_expr * type_desc
| Ccompress of type_expr * type_desc * type_desc
| Clevel of type_expr * int
+ | Cscope of type_expr * int option
| Cname of
(Path.t * type_expr list) option ref * (Path.t * type_expr list) option
| Crow of row_field option ref * row_field option
let rec forget_abbrev_rec mem path =
match mem with
Mnil ->
- assert false
+ mem
| Mcons (_, path', _, _, rem) when Path.same path path' ->
rem
| Mcons (priv, path', v, v', rem) ->
Ctype (ty, desc) -> ty.desc <- desc
| Ccompress (ty, desc, _) -> ty.desc <- desc
| Clevel (ty, level) -> ty.level <- level
+ | Cscope (ty, scope) -> ty.scope <- scope
| Cname (r, v) -> r := v
| Crow (r, v) -> r := v
| Ckind (r, v) -> r := v
let set_level ty level =
if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level));
ty.level <- level
+let set_scope ty scope =
+ if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope));
+ ty.scope <- scope
let set_univar rty ty =
log_change (Cuniv (rty, !rty)); rty := Some ty
let set_name nm v =
(* Set the desc field of [t1] to [Tlink t2], logging the old
value if there is an active snapshot *)
val set_level: type_expr -> int -> unit
+val set_scope: type_expr -> int option -> unit
val set_name:
(Path.t * type_expr list) option ref ->
(Path.t * type_expr list) option -> unit
cmt_comments = Lexer.comments ();
cmt_args = Sys.argv;
cmt_sourcefile = sourcefile;
- cmt_builddir = Sys.getcwd ();
+ cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ());
cmt_loadpath = !Config.load_path;
cmt_source_digest = source_digest;
cmt_initial_env = if need_to_clear_env then
in
associate [] [] [] (fields1, fields2)
+let rec has_dummy_method ty =
+ match repr ty with
+ {desc = Tfield (m, _, _, ty2)} ->
+ m = dummy_method || has_dummy_method ty2
+ | _ -> false
+
+let is_self_type = function
+ | Tobject (ty, _) -> has_dummy_method ty
+ | _ -> false
+
(**** Check whether an object is open ****)
(* +++ The abbreviation should eventually be expanded *)
match ty.desc with
Tvar _ ->
link_type ty (newty2 ty.level Tnil)
+ | Tfield(lab, _, _, _) when lab = dummy_method -> raise (Unify [])
| Tfield(_, _, _, ty') -> close ty'
| _ -> assert false
in
module M = struct type t let _ = (x : t list ref) end
(without this constraint, the type system would actually be unsound.)
*)
-let get_level env p =
- try
- match (Env.find_type p env).type_newtype_level with
- | None -> Path.binding_time p
- | Some (x, _) -> x
- with
- | Not_found ->
- (* no newtypes in predef *)
- Path.binding_time p
+let get_path_scope p =
+ Path.binding_time p
let rec normalize_package_path env p =
let t =
normalize_package_path env (Path.Pdot (p1', s, n))
| _ -> p
+let check_scope_escape level ty =
+ let rec aux ty =
+ let ty = repr ty in
+ if ty.level >= lowest_level then begin
+ ty.level <- pivot_level - ty.level;
+ begin match ty.scope with
+ Some lv ->
+ let var = newvar2 level in
+ if level < lv then raise (Unify [(ty,ty); (var, var)])
+ | None -> ()
+ end;
+ iter_type_expr aux ty
+ end
+ in
+ try
+ aux ty;
+ unmark_type ty
+ with Unify trace ->
+ let var = newvar2 level in
+ raise (Unify ((ty, ty) :: (var, var) :: trace))
+
+let update_scope scope ty =
+ match scope with
+ | None -> ()
+ | Some lvl ->
+ let ty = repr ty in
+ let scope =
+ match ty.scope with
+ | None -> lvl
+ | Some lvl' -> max lvl lvl'
+ in
+ if ty.level < scope then raise (Unify [(ty, newvar2 ty.level)]);
+ set_scope ty (Some scope)
+
let rec update_level env level expand ty =
let ty = repr ty in
if ty.level > level then begin
- begin match Env.gadt_instance_level env ty with
+ begin match ty.scope with
Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)])
| None -> ()
end;
match ty.desc with
- Tconstr(p, _tl, _abbrev) when level < get_level env p ->
+ Tconstr(p, _tl, _abbrev) when level < get_path_scope p ->
(* Try first to replace an abbreviation by its expansion. *)
begin try
- (* if is_newtype env p then raise Cannot_expand; *)
link_type ty (!forward_try_expand_once env ty);
update_level env level expand ty
with Cannot_expand ->
- (* +++ Levels should be restored... *)
- (* Format.printf "update_level: %i < %i@." level (get_level env p); *)
- if level < get_level env p then raise (Unify [(ty, newvar2 level)]);
- iter_type_expr (update_level env level expand) ty
+ raise (Unify [(ty, newvar2 level)])
end
| Tconstr(_, _ :: _, _) when expand ->
begin try
with Cannot_expand ->
set_level ty level;
iter_type_expr (update_level env level expand) ty
- end
+ end
| Tpackage (p, nl, tl) when level < Path.binding_time p ->
let p' = normalize_package_path env p in
if Path.same p p' then raise (Unify [(ty, newvar2 level)]);
log_type ty; ty.desc <- Tpackage (p', nl, tl);
update_level env level expand ty
| Tobject(_, ({contents=Some(p, _tl)} as nm))
- when level < get_level env p ->
+ when level < get_path_scope p ->
set_name nm None;
update_level env level expand ty
| Tvariant row ->
let row = row_repr row in
begin match row.row_name with
- | Some (p, _tl) when level < get_level env p ->
+ | Some (p, _tl) when level < get_path_scope p ->
log_type ty;
ty.desc <- Tvariant {row with row_name = None}
| _ -> ()
(* partial: we may not wish to copy the non generic types
before we call type_pat *)
-let rec copy ?env ?partial ?keep_names ty =
- let copy = copy ?env ?partial ?keep_names in
+let rec copy ?partial ?keep_names ty =
+ let copy = copy ?partial ?keep_names in
let ty = repr ty in
match ty.desc with
Tsubst ty -> ty
let desc = ty.desc in
save_desc ty desc;
let t = newvar() in (* Stub *)
- begin match env with
- Some env when Env.has_local_constraints env ->
- begin match Env.gadt_instance_level env ty with
- Some lv -> Env.add_gadt_instances env lv [t]
- | None -> ()
- end
- | _ -> ()
- end;
+ set_scope t ty.scope;
ty.desc <- Tsubst t;
t.desc <-
begin match desc with
Tlink ty2
| _ ->
(* If the row variable is not generic, we must keep it *)
- let keep = more.level <> generic_level in
+ let keep = more.level <> generic_level && partial = None in
let more' =
match more.desc with
Tsubst ty -> ty
(**** Variants of instantiations ****)
-let gadt_env env =
- if Env.has_local_constraints env
- then Some env
- else None
-
-let instance ?partial env sch =
- let env = gadt_env env in
+let instance ?partial sch =
let partial =
match partial with
None -> None
| Some keep -> Some (compute_univars sch, keep)
in
- let ty = copy ?env ?partial sch in
+ let ty = copy ?partial sch in
cleanup_types ();
ty
cleanup_types ();
ty
-let generic_instance env sch =
+let generic_instance sch =
let old = !current_level in
current_level := generic_level;
- let ty = instance env sch in
+ let ty = instance sch in
current_level := old;
ty
-let instance_list env schl =
- let env = gadt_env env in
- let tyl = List.map (fun t -> copy ?env t) schl in
+let instance_list schl =
+ let tyl = List.map (fun t -> copy t) schl in
cleanup_types ();
tyl
if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else
Printf.sprintf "%s%d" s index
-let new_declaration newtype manifest =
+let new_declaration expansion_scope manifest =
{
type_params = [];
type_arity = 0;
type_private = Public;
type_manifest = manifest;
type_variance = [];
- type_newtype_level = newtype;
+ type_is_newtype = true;
+ type_expansion_scope = expansion_scope;
type_loc = Location.none;
type_attributes = [];
type_immediate = false;
let instance_constructor ?in_pattern cstr =
begin match in_pattern with
| None -> ()
- | Some (env, newtype_lev) ->
+ | Some (env, expansion_scope) ->
let process existential =
- let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in
+ let decl = new_declaration (Some expansion_scope) None in
let name =
match repr existential with
{desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name
let expand_abbrev_gen kind find_type_expansion env ty =
check_abbrev_env env;
match ty with
- {desc = Tconstr (path, args, abbrev); level = level} ->
+ {desc = Tconstr (path, args, abbrev); level = level; scope} ->
let lookup_abbrev = proper_abbrevs path args abbrev in
begin match find_expans kind path !lookup_abbrev with
Some ty' ->
typing error *)
()
end;
+ begin try
+ update_scope scope ty';
+ with Unify _ ->
+ (* XXX This should not happen.
+ However, levels are not correctly restored after a
+ typing error *)
+ ()
+ end;
let ty' = repr ty' in
(* assert (ty != ty'); *) (* PR#7324 *)
ty'
(* For gadts, remember type as non exportable *)
(* The ambiguous level registered for ty' should be the highest *)
if !trace_gadt_instances then begin
- match max lv (Env.gadt_instance_level env ty) with
+ match max lv ty.scope with
None -> ()
| Some lv ->
if level < lv then raise (Unify [(ty, newvar2 level)]);
- Env.add_gadt_instances env lv [ty; ty']
+ set_scope ty (Some lv);
+ set_scope ty' (Some lv)
end;
ty'
end
try try_expand_head try_once env ty'
with Cannot_expand -> ty'
-let try_expand_head try_once env ty =
- let ty' = try_expand_head try_once env ty in
- begin match Env.gadt_instance_level env ty' with
- None -> ()
- | Some lv -> Env.add_gadt_instance_chain env lv ty
- end;
- ty'
-
(* Unsafe full expansion, may raise Unify. *)
let expand_head_unif env ty =
try try_expand_head try_expand_once env ty with Cannot_expand -> repr ty
begin try
(* try expanding, since [p] could be hidden *)
local_non_recursive_abbrev strict visited env p
- (try_expand_head try_expand_once env ty)
+ (try_expand_head try_expand_once_opt env ty)
with Cannot_expand ->
let params =
try (Env.find_type p' env).type_params
let univar_pairs = ref []
+(* assumption: [ty] is fully generalized. *)
+let reify_univars ty =
+ let rec subst_univar vars ty =
+ let ty = repr ty in
+ if ty.level >= lowest_level then begin
+ ty.level <- pivot_level - ty.level;
+ match ty.desc with
+ | Tvar name ->
+ save_desc ty ty.desc;
+ let t = newty2 ty.level (Tunivar name) in
+ vars := t :: !vars;
+ ty.desc <- Tsubst t
+ | _ ->
+ iter_type_expr (subst_univar vars) ty
+ end
+ in
+ let vars = ref [] in
+ subst_univar vars ty;
+ unmark_type ty;
+ let ty = copy ty in
+ cleanup_types ();
+ newty2 ty.level (Tpoly(repr ty, !vars))
+
(*****************)
(* Unification *)
information is indeed lost, but it probably does not worth it.
*)
-let newtype_level = ref None
-
-let get_newtype_level () =
- match !newtype_level with
- | None -> assert false
- | Some x -> x
-
(* a local constraint can be added only if the rhs
of the constraint does not contain any Tvars.
They need to be removed using this function *)
let reify env t =
- let newtype_level = get_newtype_level () in
let create_fresh_constr lev name =
- let decl = new_declaration (Some (newtype_level, newtype_level)) None in
let name = match name with Some s -> "$'"^s | _ -> "$" in
let path = Path.Pident (Ident.create (get_new_abstract_name name)) in
+ let binding_time = Ident.current_time () in
+ let decl = new_declaration (Some binding_time) None in
let new_env = Env.add_local_type path decl !env in
let t = newty2 lev (Tconstr (path,[],ref Mnil)) in
env := new_env;
- t
+ t, binding_time
in
let visited = ref TypeSet.empty in
let rec iterator ty =
visited := TypeSet.add ty !visited;
match ty.desc with
Tvar o ->
- let t = create_fresh_constr ty.level o in
+ let t, binding_time = create_fresh_constr ty.level o in
link_type ty t;
- if ty.level < newtype_level then
+ if ty.level < binding_time then
raise (Unify [t, newvar2 ty.level])
| Tvariant r ->
let r = row_repr r in
let m = r.row_more in
match m.desc with
Tvar o ->
- let t = create_fresh_constr m.level o in
+ let t, binding_time = create_fresh_constr m.level o in
let row =
{r with row_fields=[]; row_fixed=true; row_more = t} in
link_type m (newty2 m.level (Tvariant row));
- if m.level < newtype_level then
+ if m.level < binding_time then
raise (Unify [t, newvar2 m.level])
| _ -> assert false
end;
let is_newtype env p =
try
let decl = Env.find_type p env in
- decl.type_newtype_level <> None &&
+ decl.type_expansion_scope <> None &&
decl.type_kind = Type_abstract &&
decl.type_private = Public
with Not_found -> false
let non_aliasable p decl =
(* in_pervasives p || (subsumed by in_current_module) *)
- in_current_module p && decl.type_newtype_level = None
+ in_current_module p && not decl.type_is_newtype
let is_instantiable env p =
try
with Not_found ->
TypePairs.add type_pairs (t1', t2') ();
match (t1'.desc, t2'.desc) with
- (Tvar _, Tvar _) -> assert false
+ | (Tvar _, _)
+ | (_, Tvar _) ->
+ ()
| (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _))
when l1 = l2 || not (is_optional l1 || is_optional l2) ->
mcomp type_pairs env t1 t2;
end
in find ty; unmark_type ty; !lowest
-let find_newtype_level env path =
- try match (Env.find_type path env).type_newtype_level with
- Some x -> x
- | None -> raise Not_found
- with Not_found -> let lev = Path.binding_time path in (lev, lev)
+let find_expansion_scope env path =
+ match (Env.find_type path env).type_expansion_scope with
+ | Some x -> x
+ | None -> assert false
+
+let gadt_equations_level = ref None
+
+let get_gadt_equations_level () =
+ match !gadt_equations_level with
+ | None -> assert false
+ | Some x -> x
let add_gadt_equation env source destination =
+ (* Format.eprintf "@[add_gadt_equation %s %a@]@."
+ (Path.name source) !Btype.print_raw destination; *)
if local_non_recursive_abbrev !env source destination then begin
let destination = duplicate_type destination in
- let source_lev = find_newtype_level !env source in
- let decl = new_declaration (Some source_lev) (Some destination) in
- let newtype_level = get_newtype_level () in
- env := Env.add_local_constraint source decl newtype_level !env;
+ let expansion_scope =
+ max (Path.binding_time source) (get_gadt_equations_level ())
+ in
+ let decl = new_declaration (Some expansion_scope) (Some destination) in
+ env := Env.add_local_type source decl !env;
cleanup_abbrev ()
end
if level = generic_level then duplicate_type ty else
let old = !current_level in
current_level := level;
- let ty = instance env ty in
+ let ty = instance ty in
current_level := old;
ty
let d1 = t1.desc in
link_type t1 t2;
try
- update_level env t1.level t2
+ update_level env t1.level t2;
+ update_scope t1.scope t2
with Unify _ as e ->
t1.desc <- d1;
raise e
| (Tunivar _, Tunivar _) ->
unify_univar t1 t2 !univar_pairs;
update_level !env t1.level t2;
+ update_scope t1.scope t2;
link_type t1 t2
| (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
when Path.same p1 p2 (* && actual_mode !env = Old *)
&& not (has_cached_expansion p1 !a1
|| has_cached_expansion p2 !a2) ->
update_level !env t1.level t2;
+ update_scope t1.scope t2;
link_type t1 t2
| (Tconstr (p1, [], _), Tconstr (p2, [], _))
when Env.has_local_constraints !env
&& is_newtype !env p1 && is_newtype !env p2 ->
(* Do not use local constraints more than necessary *)
begin try
- if find_newtype_level !env p1 < find_newtype_level !env p2 then
+ if find_expansion_scope !env p1 > find_expansion_scope !env p2 then
unify env t1 (try_expand_once !env t2)
else
unify env (try_expand_once !env t1) t2
let t1' = expand_head_unif !env t1 in
let t2' = expand_head_unif !env t2 in
let lv = min t1'.level t2'.level in
+ let scope = max t1'.scope t2'.scope in
update_level !env lv t2;
update_level !env lv t1;
+ update_scope scope t2;
+ update_scope scope t1;
if unify_eq t1' t2' then () else
let t1 = repr t1 and t2 = repr t2 in
- if !trace_gadt_instances then begin
- (* All types in chains already have the same ambiguity levels *)
- let ilevel t =
- match Env.gadt_instance_level !env t with None -> 0 | Some lv -> lv in
- let lv1 = ilevel t1 and lv2 = ilevel t2 in
- if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else
- if lv2 > lv1 then Env.add_gadt_instance_chain !env lv2 t1
- end;
let t1, t2 =
if !Clflags.principal
&& (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then
begin match !umode with
| Expression ->
occur !env t1' t2';
- link_type t1' t2
+ if is_self_type d1 (* PR#7711: do not abbreviate self type *)
+ then link_type t1' t2'
+ else link_type t1' t2
| Pattern ->
add_type_equality t1' t2'
end;
when is_instantiable !env path && is_instantiable !env path'
&& !generate_equations ->
let source, destination =
- if find_newtype_level !env path > find_newtype_level !env path'
+ if get_path_scope path > get_path_scope path'
then path , t2'
else path', t1'
in
(fun (n, k1, t1, k2, t2) ->
unify_kind k1 k2;
try
- if !trace_gadt_instances then update_level !env va.level t1;
+ if !trace_gadt_instances then begin
+ update_level !env va.level t1;
+ update_scope va.scope t1
+ end;
unify env t1 t2
with Unify trace ->
raise (Unify ((newty (Tfield(n, k1, t1, newty Tnil)),
else
let ty = newgenty (Tvariant {row0 with row_fields = rest}) in
update_level !env rm.level ty;
+ update_scope rm.scope ty;
link_type rm ty
in
let md1 = rm1.desc and md2 = rm2.desc in
| (tu::_, []) | ([], tu::_) -> occur_univar !env tu
end;
(* Is this handling of levels really principal? *)
- List.iter (update_level !env (repr more).level) (tl1' @ tl2');
+ List.iter (fun ty ->
+ let rm = repr more in
+ update_level !env rm.level ty;
+ update_scope rm.scope ty;
+ ) (tl1' @ tl2');
let e = ref None in
let f1' = Reither(c1 || c2, tl1', m1 || m2, e)
and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in
| Rabsent, Rabsent -> ()
| Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 ->
set_row_field e1 f2;
- update_level !env (repr more).level t2;
+ let rm = repr more in
+ update_level !env rm.level t2;
+ update_scope rm.scope t2;
(try List.iter (fun t1 -> unify env t1 t2) tl
with exn -> e1 := None; raise exn)
| Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 ->
set_row_field e2 f1;
- update_level !env (repr more).level t1;
+ let rm = repr more in
+ update_level !env rm.level t1;
+ update_scope rm.scope t1;
(try List.iter (unify env t1) tl
with exn -> e2 := None; raise exn)
| Reither(true, [], _, e1), Rpresent None when not fixed1 ->
undo_compress snap;
raise (Unification_recursive_abbrev (expand_trace !env [(ty1,ty2)]))
-let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 =
+let unify_gadt ~equations_level:lev (env:Env.t ref) ty1 ty2 =
try
univar_pairs := [];
- newtype_level := Some lev;
+ gadt_equations_level := Some lev;
set_mode_pattern ~generate:true ~injective:true
(fun () -> unify env ty1 ty2);
- newtype_level := None;
+ gadt_equations_level := None;
TypePairs.clear unify_eq_set;
with e ->
- newtype_level := None;
+ gadt_equations_level := None;
TypePairs.clear unify_eq_set;
raise e
begin try
occur env t1 t2;
update_level env t1.level t2;
+ update_scope t1.scope t2;
link_type t1 t2;
reset_trace_gadt_instances reset_tracing;
with Unify trace ->
let ty1 = newvar () in
let ty' = newobj ty1 in
update_level env ty.level ty';
+ update_scope ty.scope ty';
link_type ty ty';
filter_method_field env name priv ty1
| Tobject(f, _) ->
match (t1.desc, t2.desc) with
(Tvar _, _) when may_instantiate inst_nongen t1 ->
moregen_occur env t1.level t2;
+ update_scope t1.scope t2;
occur env t1 t2;
link_type t1 t2
| (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
match (t1'.desc, t2'.desc) with
(Tvar _, _) when may_instantiate inst_nongen t1' ->
moregen_occur env t1'.level t2;
+ update_scope t1'.scope t2;
link_type t1' t2
| (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
|| !Clflags.classic && not (is_optional l1 || is_optional l2) ->
newgenty (Tvariant {row2 with row_fields = r2; row_name = None})
in
moregen_occur env rm1.level ext;
+ update_scope rm1.scope ext;
link_type rm1 ext
| Tconstr _, Tconstr _ ->
moregen inst_nongen type_pairs env rm1 rm2
then copied with [duplicate_type]. That way, its levels won't be
changed.
*)
- let subj = duplicate_type (instance env subj_sch) in
+ let subj = duplicate_type (instance subj_sch) in
current_level := generic_level;
(* Duplicate generic variables *)
- let patt = instance env pat_sch in
+ let patt = instance pat_sch in
let res =
try moregen inst_nongen (TypePairs.create 13) env patt subj; true with
Unify _ -> false
| _ -> CM_Hide_public lab::err
end
in
- if Concr.mem lab sign1.csig_concr then err
+ if lab = dummy_method || Concr.mem lab sign1.csig_concr then err
else CM_Hide_virtual ("method", lab) :: err)
miss1 []
in
type_manifest = tm;
type_private = priv;
type_variance = decl.type_variance;
- type_newtype_level = None;
+ type_is_newtype = false;
+ type_expansion_scope = None;
type_loc = decl.type_loc;
type_attributes = decl.type_attributes;
type_immediate = decl.type_immediate;
(* Only generalize some part of the type
Make the remaining of the type non-generalizable *)
-val instance: ?partial:bool -> Env.t -> type_expr -> type_expr
+val check_scope_escape : int -> type_expr -> unit
+ (* [check_scope_escape lvl ty] ensures that [ty] could be raised
+ to the level [lvl] without any scope escape.
+ Raises [Unify] otherwise *)
+
+val instance: ?partial:bool -> type_expr -> type_expr
(* Take an instance of a type scheme *)
(* partial=None -> normal
partial=false -> newvar() for non generic subterms
partial=true -> newty2 ty.level Tvar for non generic subterms *)
val instance_def: type_expr -> type_expr
(* use defaults *)
-val generic_instance: Env.t -> type_expr -> type_expr
+val generic_instance: type_expr -> type_expr
(* Same as instance, but new nodes at generic_level *)
-val instance_list: Env.t -> type_expr list -> type_expr list
+val instance_list: type_expr list -> type_expr list
(* Take an instance of a list of type schemes *)
val instance_constructor:
?in_pattern:Env.t ref * int ->
val unify: Env.t -> type_expr -> type_expr -> unit
(* Unify the two types given. Raise [Unify] if not possible. *)
-val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit
+val unify_gadt: equations_level:int -> Env.t ref -> type_expr -> type_expr -> unit
(* Unify the two types given and update the environment with the
local constraints. Raise [Unify] if not possible. *)
val unify_var: Env.t -> type_expr -> type_expr -> unit
(* Same as [moregeneral false], implemented using the two above
functions and backtracking. Ignore levels *)
+val reify_univars : Types.type_expr -> Types.type_expr
+ (* Replaces all the variables of a type by a univar. *)
+
type class_match_failure =
CM_Virtual_class
| CM_Parameter_arity_mismatch of int * int
val package_subtype :
(Env.t -> Path.t -> Longident.t list -> type_expr list ->
Path.t -> Longident.t list -> type_expr list -> bool) ref
+
+val mcomp : Env.t -> type_expr -> type_expr -> unit
type_private = priv;
type_manifest = None;
type_variance = List.map (fun _ -> Variance.full) type_params;
- type_newtype_level = None;
+ type_is_newtype = false;
+ type_expansion_scope = None;
type_loc = Location.none;
type_attributes = [];
type_immediate = false;
cstr_inlined;
}
-let none = {desc = Ttuple []; level = -1; id = -1}
+let none = {desc = Ttuple []; level = -1; scope = None; id = -1}
(* Clearly ill-formed type *)
let dummy_label =
{ lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
| Env_modtype of summary * Ident.t * modtype_declaration
| Env_class of summary * Ident.t * class_declaration
| Env_cltype of summary * Ident.t * class_type_declaration
- | Env_open of summary * Path.t
+ | Env_open of summary * StringSet.t * Path.t
| Env_functor_arg of summary * Ident.t
| Env_constraints of summary * type_declaration PathMap.t
| Env_copy_types of summary * string list
| None -> raise exn
end
- let rec find_name mark name tbl =
+ let rec find_name ~mark name tbl =
try
let (id, desc) = Ident.find_name name tbl.current in
Pident id, desc
if mark then begin match using with
| None -> ()
| Some f ->
- begin try f name (Some (snd (find_name false name next), snd res))
+ begin try f name (Some (snd (find_name ~mark:false name next), snd res))
with Not_found -> f name None
end
end;
res
with Not_found ->
- find_name mark name next
+ find_name ~mark name next
end
| None ->
raise exn
end
- let find_name name tbl = find_name true name tbl
-
let rec update name f tbl =
try
let (id, desc) = Ident.find_name name tbl.current in
constructor_description list * label_description list
let in_signature_flag = 0x01
-let implicit_coercion_flag = 0x02
type t = {
values: value_description IdTbl.t;
functor_args: unit Ident.tbl;
summary: summary;
local_constraints: type_declaration PathMap.t;
- gadt_instances: (int * TypeSet.t ref) list;
flags: int;
}
let copy_local ~from env =
{ env with
local_constraints = from.local_constraints;
- gadt_instances = from.gadt_instances;
flags = from.flags }
let same_constr = ref (fun _ _ _ -> assert false)
modules = IdTbl.empty; modtypes = IdTbl.empty;
components = IdTbl.empty; classes = IdTbl.empty;
cltypes = IdTbl.empty;
- summary = Env_empty; local_constraints = PathMap.empty; gadt_instances = [];
+ summary = Env_empty; local_constraints = PathMap.empty;
flags = 0;
functor_args = Ident.empty;
}
in
{env with flags}
-let implicit_coercion env =
- {env with flags = env.flags lor implicit_coercion_flag}
-
let is_in_signature env = env.flags land in_signature_flag <> 0
-let is_implicit_coercion env = env.flags land implicit_coercion_flag <> 0
let is_ident = function
Pident _ -> true
let crc_units = Consistbl.create()
-module StringSet =
- Set.Make(struct type t = string let compare = String.compare end)
-
let imported_units = ref StringSet.empty
let add_import s =
acknowledge_pers_struct check name ps
(* Emits a warning if there is no valid cmi for name *)
-let check_pers_struct name =
+let check_pers_struct ~loc name =
try
ignore (find_pers_struct false name)
with
| Not_found ->
let warn = Warnings.No_cmi_file(name, None) in
- Location.prerr_warning Location.none warn
+ Location.prerr_warning loc warn
| Cmi_format.Error err ->
let msg = Format.asprintf "%a" Cmi_format.report_error err in
let warn = Warnings.No_cmi_file(name, Some msg) in
- Location.prerr_warning Location.none warn
+ Location.prerr_warning loc warn
| Error err ->
let msg =
match err with
| Illegal_value_name _ -> assert false
in
let warn = Warnings.No_cmi_file(name, Some msg) in
- Location.prerr_warning Location.none warn
+ Location.prerr_warning loc warn
let read_pers_struct modname filename =
read_pers_struct true modname filename
let find_pers_struct name =
find_pers_struct true name
-let check_pers_struct name =
+let check_pers_struct ~loc name =
if not (Hashtbl.mem persistent_structures name) then begin
(* PR#6843: record the weak dependency ([add_import]) regardless of
whether the check succeeds, to help make builds more
add_import name;
if (Warnings.is_active (Warnings.No_cmi_file("", None))) then
!add_delayed_check_forward
- (fun () -> check_pers_struct name)
+ (fun () -> check_pers_struct ~loc name)
end
let reset_cache () =
| Some body when decl.type_private = Public
|| decl.type_kind <> Type_abstract
|| Btype.has_constr_row body ->
- (decl.type_params, body, may_map snd decl.type_newtype_level)
+ (decl.type_params, body, decl.type_expansion_scope)
(* The manifest type of Private abstract data types without
private row are still considered unknown to the type system.
Hence, this case is caught by the following clause that also handles
match decl.type_manifest with
(* The manifest type of Private abstract data types can still get
an approximation using their manifest type. *)
- | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level)
+ | Some body ->
+ (decl.type_params, body, decl.type_expansion_scope)
| _ -> raise Not_found
let find_modtype_expansion path env =
Location.deprecated loc (Printf.sprintf "module %s%s" (Path.name p) txt)
| _ -> ()
-let mark_module_used env name loc =
- if not (is_implicit_coercion env) then
- try Hashtbl.find module_declarations (name, loc) ()
- with Not_found -> ()
+let mark_module_used name loc =
+ try Hashtbl.find module_declarations (name, loc) ()
+ with Not_found -> ()
-let rec lookup_module_descr_aux ?loc lid env =
+let rec lookup_module_descr_aux ?loc ~mark lid env =
match lid with
Lident s ->
begin try
- IdTbl.find_name s env.components
+ IdTbl.find_name ~mark s env.components
with Not_found ->
if s = !current_unit then raise Not_found;
let ps = find_pers_struct s in
(Pident(Ident.create_persistent s), ps.ps_comps)
end
| Ldot(l, s) ->
- let (p, descr) = lookup_module_descr ?loc l env in
+ let (p, descr) = lookup_module_descr ?loc ~mark l env in
begin match get_components descr with
Structure_comps c ->
let (descr, pos) = Tbl.find_str s c.comp_components in
raise Not_found
end
| Lapply(l1, l2) ->
- let (p1, desc1) = lookup_module_descr ?loc l1 env in
- let p2 = lookup_module ~load:true ?loc l2 env in
+ let (p1, desc1) = lookup_module_descr ?loc ~mark l1 env in
+ let p2 = lookup_module ~load:true ~mark ?loc l2 env in
let {md_type=mty2} = find_module p2 env in
begin match get_components desc1 with
Functor_comps f ->
let loc = match loc with Some l -> l | None -> Location.none in
- Misc.may (!check_modtype_inclusion ~loc env mty2 p2) f.fcomp_arg;
+ (match f.fcomp_arg with
+ | None -> raise Not_found (* PR#7611 *)
+ | Some arg -> !check_modtype_inclusion ~loc env mty2 p2 arg);
(Papply(p1, p2), !components_of_functor_appl' f env p1 p2)
| Structure_comps _ ->
raise Not_found
end
-and lookup_module_descr ?loc lid env =
- let (p, comps) as res = lookup_module_descr_aux ?loc lid env in
- mark_module_used env (Path.last p) comps.loc;
+and lookup_module_descr ?loc ~mark lid env =
+ let (p, comps) as res = lookup_module_descr_aux ?loc ~mark lid env in
+ if mark then mark_module_used (Path.last p) comps.loc;
(*
Format.printf "USE module %s at %a@." (Path.last p)
Location.print comps.loc;
report_deprecated ?loc p comps.deprecated;
res
-and lookup_module ~load ?loc lid env : Path.t =
+and lookup_module ~load ?loc ~mark lid env : Path.t =
match lid with
Lident s ->
begin try
- let (p, data) = IdTbl.find_name s env.modules in
+ let (p, data) = IdTbl.find_name ~mark s env.modules in
let {md_loc; md_attributes; md_type} =
EnvLazy.force subst_modtype_maker data
in
- mark_module_used env s md_loc;
+ if mark then mark_module_used s md_loc;
begin match md_type with
| Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" ->
(* see #5965 *)
with Not_found ->
if s = !current_unit then raise Not_found;
let p = Pident(Ident.create_persistent s) in
- if !Clflags.transparent_modules && not load then check_pers_struct s
+ if !Clflags.transparent_modules && not load
+ then
+ let loc = match loc with Some l -> l | None -> Location.none in
+ check_pers_struct ~loc s
else begin
let ps = find_pers_struct s in
report_deprecated ?loc p ps.ps_comps.deprecated
p
end
| Ldot(l, s) ->
- let (p, descr) = lookup_module_descr ?loc l env in
+ let (p, descr) = lookup_module_descr ?loc ~mark l env in
begin match get_components descr with
Structure_comps c ->
let (_data, pos) = Tbl.find_str s c.comp_modules in
let (comps, _) = Tbl.find_str s c.comp_components in
- mark_module_used env s comps.loc;
+ if mark then mark_module_used s comps.loc;
let p = Pdot(p, s, pos) in
report_deprecated ?loc p comps.deprecated;
p
raise Not_found
end
| Lapply(l1, l2) ->
- let (p1, desc1) = lookup_module_descr ?loc l1 env in
- let p2 = lookup_module ~load:true ?loc l2 env in
+ let (p1, desc1) = lookup_module_descr ?loc ~mark l1 env in
+ let p2 = lookup_module ~load:true ?loc ~mark l2 env in
let {md_type=mty2} = find_module p2 env in
let p = Papply(p1, p2) in
begin match get_components desc1 with
Functor_comps f ->
let loc = match loc with Some l -> l | None -> Location.none in
- Misc.may (!check_modtype_inclusion ~loc env mty2 p2) f.fcomp_arg;
+ (match f.fcomp_arg with
+ | None -> raise Not_found (* PR#7611 *)
+ | Some arg -> (!check_modtype_inclusion ~loc env mty2 p2) arg);
p
| Structure_comps _ ->
raise Not_found
end
-let lookup proj1 proj2 ?loc lid env =
+let lookup proj1 proj2 ?loc ~mark lid env =
match lid with
Lident s ->
- IdTbl.find_name s (proj1 env)
+ IdTbl.find_name ~mark s (proj1 env)
| Ldot(l, s) ->
- let (p, desc) = lookup_module_descr ?loc l env in
+ let (p, desc) = lookup_module_descr ?loc ~mark l env in
begin match get_components desc with
Structure_comps c ->
let (data, pos) = Tbl.find_str s (proj2 c) in
| Lapply _ ->
raise Not_found
-let lookup_all_simple proj1 proj2 shadow ?loc lid env =
+let lookup_all_simple proj1 proj2 shadow ?loc ~mark lid env =
match lid with
Lident s ->
let xl = TycompTbl.find_all s (proj1 env) in
in
do_shadow xl
| Ldot(l, s) ->
- let (_p, desc) = lookup_module_descr ?loc l env in
+ let (_p, desc) = lookup_module_descr ?loc ~mark l env in
begin match get_components desc with
Structure_comps c ->
let comps =
let values = List.fold_left (fun env s -> IdTbl.update s f env) env.values l in
{env with values; summary = Env_copy_types (env.summary, l)}
-let mark_value_used env name vd =
- if not (is_implicit_coercion env) then
- try Hashtbl.find value_declarations (name, vd.val_loc) ()
- with Not_found -> ()
+let mark_value_used name vd =
+ try Hashtbl.find value_declarations (name, vd.val_loc) ()
+ with Not_found -> ()
-let mark_type_used env name vd =
- if not (is_implicit_coercion env) then
- try Hashtbl.find type_declarations (name, vd.type_loc) ()
- with Not_found -> ()
+let mark_type_used name vd =
+ try Hashtbl.find type_declarations (name, vd.type_loc) ()
+ with Not_found -> ()
-let mark_constructor_used usage env name vd constr =
- if not (is_implicit_coercion env) then
- try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage
- with Not_found -> ()
+let mark_constructor_used usage name vd constr =
+ try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage
+ with Not_found -> ()
-let mark_extension_used usage env ext name =
- if not (is_implicit_coercion env) then
- let ty_name = Path.last ext.ext_type_path in
- try Hashtbl.find used_constructors (ty_name, ext.ext_loc, name) usage
- with Not_found -> ()
+let mark_extension_used usage ext name =
+ let ty_name = Path.last ext.ext_type_path in
+ try Hashtbl.find used_constructors (ty_name, ext.ext_loc, name) usage
+ with Not_found -> ()
let set_value_used_callback name vd callback =
let key = (name, vd.val_loc) in
in
Hashtbl.replace type_declarations key (fun () -> callback old)
-let lookup_value ?loc lid env =
- let (_, desc) as r = lookup_value ?loc lid env in
- mark_value_used env (Longident.last lid) desc;
+let lookup_value ?loc ?(mark = true) lid env =
+ let (_, desc) as r = lookup_value ?loc ~mark lid env in
+ if mark then mark_value_used (Longident.last lid) desc;
r
-let lookup_type ?loc lid env =
- let (path, (decl, _)) = lookup_type ?loc lid env in
- mark_type_used env (Longident.last lid) decl;
+let lookup_type ?loc ?(mark = true) lid env =
+ let (path, (decl, _)) = lookup_type ?loc ~mark lid env in
+ if mark then mark_type_used (Longident.last lid) decl;
path
let mark_type_path env path =
try
let decl = find_type path env in
- mark_type_used env (Path.last path) decl
+ mark_type_used (Path.last path) decl
with Not_found -> ()
let ty_path t =
| {desc=Tconstr(path, _, _)} -> path
| _ -> assert false
-let lookup_constructor ?loc lid env =
- match lookup_all_constructors ?loc lid env with
+let lookup_constructor ?loc ?(mark = true) lid env =
+ match lookup_all_constructors ?loc ~mark lid env with
[] -> raise Not_found
| (desc, use) :: _ ->
- mark_type_path env (ty_path desc.cstr_res);
- use ();
+ if mark then begin
+ mark_type_path env (ty_path desc.cstr_res);
+ use ()
+ end;
desc
let is_lident = function
Lident _ -> true
| _ -> false
-let lookup_all_constructors ?loc lid env =
+let lookup_all_constructors ?loc ?(mark = true) lid env =
try
- let cstrs = lookup_all_constructors ?loc lid env in
+ let cstrs = lookup_all_constructors ?loc ~mark lid env in
let wrap_use desc use () =
- mark_type_path env (ty_path desc.cstr_res);
- use ()
+ if mark then begin
+ mark_type_path env (ty_path desc.cstr_res);
+ use ()
+ end
in
List.map (fun (cstr, use) -> (cstr, wrap_use cstr use)) cstrs
with
Not_found when is_lident lid -> []
let mark_constructor usage env name desc =
- if not (is_implicit_coercion env)
- then match desc.cstr_tag with
+ match desc.cstr_tag with
| Cstr_extension _ ->
begin
let ty_path = ty_path desc.cstr_res in
let ty_path = ty_path desc.cstr_res in
let ty_decl = try find_type ty_path env with Not_found -> assert false in
let ty_name = Path.last ty_path in
- mark_constructor_used usage env ty_name ty_decl name
+ mark_constructor_used usage ty_name ty_decl name
-let lookup_label ?loc lid env =
- match lookup_all_labels ?loc lid env with
+let lookup_label ?loc ?(mark = true) lid env =
+ match lookup_all_labels ?loc ~mark lid env with
[] -> raise Not_found
| (desc, use) :: _ ->
- mark_type_path env (ty_path desc.lbl_res);
- use ();
+ if mark then begin
+ mark_type_path env (ty_path desc.lbl_res);
+ use ()
+ end;
desc
-let lookup_all_labels ?loc lid env =
+let lookup_all_labels ?loc ?(mark = true) lid env =
try
- let lbls = lookup_all_labels ?loc lid env in
+ let lbls = lookup_all_labels ?loc ~mark lid env in
let wrap_use desc use () =
- mark_type_path env (ty_path desc.lbl_res);
- use ()
+ if mark then begin
+ mark_type_path env (ty_path desc.lbl_res);
+ use ()
+ end
in
List.map (fun (lbl, use) -> (lbl, wrap_use lbl use)) lbls
with
Not_found when is_lident lid -> []
-let lookup_class ?loc lid env =
- let (_, desc) as r = lookup_class ?loc lid env in
+let lookup_module ~load ?loc ?(mark = true) lid env =
+ lookup_module ~load ?loc ~mark lid env
+
+let lookup_modtype ?loc ?(mark = true) lid env =
+ lookup_modtype ?loc ~mark lid env
+
+let lookup_class ?loc ?(mark = true) lid env =
+ let (_, desc) as r = lookup_class ?loc ~mark lid env in
(* special support for Typeclass.unbound_class *)
- if Path.name desc.cty_path = "" then ignore (lookup_type ?loc lid env)
- else mark_type_path env desc.cty_path;
+ if Path.name desc.cty_path = "" then ignore (lookup_type ?loc ~mark lid env)
+ else if mark then mark_type_path env desc.cty_path;
r
-let lookup_cltype ?loc lid env =
- let (_, desc) as r = lookup_cltype ?loc lid env in
+let lookup_cltype ?loc ?(mark = true) lid env =
+ let (_, desc) as r = lookup_cltype ?loc ~mark lid env in
if Path.name desc.clty_path = "" then ignore (lookup_type ?loc lid env)
else mark_type_path env desc.clty_path;
mark_type_path env desc.clty_path;
(find_shadowed
(fun env -> env.types) (fun comps -> comps.comp_types) path env)
-
-(* GADT instance tracking *)
-
-let add_gadt_instance_level lv env =
- {env with
- gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances}
-
-let is_Tlink = function {desc = Tlink _} -> true | _ -> false
-
-let gadt_instance_level env t =
- let rec find_instance = function
- [] -> None
- | (lv, r) :: rem ->
- if TypeSet.exists is_Tlink !r then
- (* Should we use set_typeset ? *)
- r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty;
- if TypeSet.mem t !r then Some lv else find_instance rem
- in find_instance env.gadt_instances
-
-let add_gadt_instances env lv tl =
- let r =
- try List.assoc lv env.gadt_instances with Not_found -> assert false in
- (* Format.eprintf "Added";
- List.iter (fun ty -> Format.eprintf "@ %a" !Btype.print_raw ty) tl;
- Format.eprintf "@."; *)
- set_typeset r (List.fold_right TypeSet.add tl !r)
-
-(* Only use this after expand_head! *)
-let add_gadt_instance_chain env lv t =
- let r =
- try List.assoc lv env.gadt_instances with Not_found -> assert false in
- let rec add_instance t =
- let t = repr t in
- if not (TypeSet.mem t !r) then begin
- (* Format.eprintf "@ %a" !Btype.print_raw t; *)
- set_typeset r (TypeSet.add t !r);
- match t.desc with
- Tconstr (p, _, memo) ->
- may add_instance (find_expans Private p !memo)
- | _ -> ()
- end
- in
- (* Format.eprintf "Added chain"; *)
- add_instance t
- (* Format.eprintf "@." *)
-
(* Expand manifest module type names at the top of the given module type *)
let rec scrape_alias env ?path mty =
{ env with
local_constraints = PathMap.add path info env.local_constraints }
-let add_local_constraint path info elv env =
- match info with
- {type_manifest = Some _; type_newtype_level = Some (lv, _)} ->
- (* elv is the expansion level, lv is the definition level *)
- let info = {info with type_newtype_level = Some (lv, elv)} in
- add_local_type path info env
- | _ -> assert false
-
(* Insertion of bindings by name *)
(* Open a signature path *)
-let add_components slot root env0 comps =
+let add_components ?filter_modules slot root env0 comps =
let add_l w comps env0 =
TycompTbl.add_open slot w comps env0
in
let add w comps env0 = IdTbl.add_open slot w root comps env0 in
+ let skipped_modules = ref StringSet.empty in
+ let filter tbl env0_tbl =
+ match filter_modules with
+ | None -> tbl
+ | Some f ->
+ Tbl.fold (fun m x acc ->
+ if f m then
+ Tbl.add m x acc
+ else begin
+ assert
+ (match IdTbl.find_name m env0_tbl~mark:false with
+ | (_ : _ * _) -> false
+ | exception _ -> true);
+ skipped_modules := StringSet.add m !skipped_modules;
+ acc
+ end)
+ tbl Tbl.empty
+ in
+
+ let filter_and_add w comps env0 =
+ let comps = filter comps env0 in
+ add w comps env0
+ in
+
let constrs =
add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs
in
add (fun x -> `Class_type x) comps.comp_cltypes env0.cltypes
in
let components =
- add (fun x -> `Component x) comps.comp_components env0.components
+ filter_and_add (fun x -> `Component x) comps.comp_components env0.components
in
let modules =
- add (fun x -> `Module x) comps.comp_modules env0.modules
+ filter_and_add (fun x -> `Module x) comps.comp_modules env0.modules
in
{ env0 with
- summary = Env_open(env0.summary, root);
+ summary = Env_open(env0.summary, !skipped_modules, root);
constrs;
labels;
values;
modules;
}
-let open_signature slot root env0 =
+let open_signature ?filter_modules slot root env0 =
match get_components (find_module_descr root env0) with
| Functor_comps _ -> None
- | Structure_comps comps -> Some (add_components slot root env0 comps)
+ | Structure_comps comps ->
+ Some (add_components ?filter_modules slot root env0 comps)
(* Open a signature from a file *)
| Some env -> env
| None -> assert false (* a compilation unit cannot refer to a functor *)
+let open_signature_of_initially_opened_module root env =
+ let load_path = !Config.load_path in
+ let filter_modules m =
+ match Misc.find_in_path_uncap load_path (m ^ ".cmi") with
+ | (_ : string) -> false
+ | exception Not_found -> true
+ in
+ open_signature None root env ~filter_modules
+
+let open_signature_from_env_summary root env ~hidden_submodules =
+ let filter_modules =
+ if StringSet.is_empty hidden_submodules then
+ None
+ else
+ Some (fun m -> not (StringSet.mem m hidden_submodules))
+ in
+ open_signature None root env ?filter_modules
+
let open_signature
?(used_slot = ref false)
- ?(loc = Location.none) ?(toplevel = false) ovf root env =
+ ?(loc = Location.none) ?(toplevel = false)
+ ovf root env =
if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost
&& (Warnings.is_active (Warnings.Unused_open "")
|| Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))
(fun name (p, data) acc -> f name p data acc)
(proj1 env) acc
| Some l ->
- let p, desc = lookup_module_descr l env in
+ let p, desc = lookup_module_descr ~mark:true l env in
begin match get_components desc with
Structure_comps c ->
Tbl.fold
(fun data acc -> f data acc)
(proj1 env) acc
| Some l ->
- let (_p, desc) = lookup_module_descr l env in
+ let (_p, desc) = lookup_module_descr ~mark:true l env in
begin match get_components desc with
Structure_comps c ->
Tbl.fold
persistent_structures
acc
| Some l ->
- let p, desc = lookup_module_descr l env in
+ let p, desc = lookup_module_descr ~mark:true l env in
begin match get_components desc with
Structure_comps c ->
Tbl.fold
| Env_modtype of summary * Ident.t * modtype_declaration
| Env_class of summary * Ident.t * class_declaration
| Env_cltype of summary * Ident.t * class_type_declaration
- | Env_open of summary * Path.t
+ | Env_open of summary * Misc.StringSet.t * Path.t
+ (** The string set argument of [Env_open] represents a list of module names
+ to skip, i.e. that won't be imported in the toplevel namespace. *)
| Env_functor_arg of summary * Ident.t
| Env_constraints of summary * type_declaration PathMap.t
| Env_copy_types of summary * string list
val add_required_global: Ident.t -> unit
val has_local_constraints: t -> bool
-val add_gadt_instance_level: int -> t -> t
-val gadt_instance_level: t -> type_expr -> int option
-val add_gadt_instances: t -> int -> type_expr list -> unit
-val add_gadt_instance_chain: t -> int -> type_expr -> unit
(* Lookup by long identifiers *)
(* ?loc is used to report 'deprecated module' warnings *)
val lookup_value:
- ?loc:Location.t -> Longident.t -> t -> Path.t * value_description
+ ?loc:Location.t -> ?mark:bool ->
+ Longident.t -> t -> Path.t * value_description
val lookup_constructor:
- ?loc:Location.t -> Longident.t -> t -> constructor_description
+ ?loc:Location.t -> ?mark:bool -> Longident.t -> t -> constructor_description
val lookup_all_constructors:
- ?loc:Location.t ->
+ ?loc:Location.t -> ?mark:bool ->
Longident.t -> t -> (constructor_description * (unit -> unit)) list
val lookup_label:
- ?loc:Location.t -> Longident.t -> t -> label_description
+ ?loc:Location.t -> ?mark:bool ->
+ Longident.t -> t -> label_description
val lookup_all_labels:
- ?loc:Location.t ->
+ ?loc:Location.t -> ?mark:bool ->
Longident.t -> t -> (label_description * (unit -> unit)) list
val lookup_type:
- ?loc:Location.t -> Longident.t -> t -> Path.t
+ ?loc:Location.t -> ?mark:bool -> Longident.t -> t -> Path.t
(* Since 4.04, this function no longer returns [type_description].
To obtain it, you should either call [Env.find_type], or replace
it by [Typetexp.find_type] *)
val lookup_module:
- load:bool -> ?loc:Location.t -> Longident.t -> t -> Path.t
+ load:bool -> ?loc:Location.t -> ?mark:bool -> Longident.t -> t -> Path.t
val lookup_modtype:
- ?loc:Location.t -> Longident.t -> t -> Path.t * modtype_declaration
+ ?loc:Location.t -> ?mark:bool ->
+ Longident.t -> t -> Path.t * modtype_declaration
val lookup_class:
- ?loc:Location.t -> Longident.t -> t -> Path.t * class_declaration
+ ?loc:Location.t -> ?mark:bool ->
+ Longident.t -> t -> Path.t * class_declaration
val lookup_cltype:
- ?loc:Location.t -> Longident.t -> t -> Path.t * class_type_declaration
+ ?loc:Location.t -> ?mark:bool ->
+ Longident.t -> t -> Path.t * class_type_declaration
val copy_types: string list -> t -> t
(* Used only in Typecore.duplicate_ident_types. *)
val add_modtype: Ident.t -> modtype_declaration -> t -> t
val add_class: Ident.t -> class_declaration -> t -> t
val add_cltype: Ident.t -> class_type_declaration -> t -> t
-val add_local_constraint: Path.t -> type_declaration -> int -> t -> t
val add_local_type: Path.t -> type_declaration -> t -> t
(* Insertion of all fields of a signature. *)
not a structure. *)
val open_signature:
?used_slot:bool ref ->
- ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> Path.t ->
+ ?loc:Location.t -> ?toplevel:bool ->
+ Asttypes.override_flag -> Path.t ->
t -> t option
+(* Similar to [open_signature], except that modules from the load path
+ have precedence over sub-modules of the opened module.
+
+ For instance, if opening a module [M] with a sub-module [X]:
+ - if the load path contains a [x.cmi] file, then resolving [X] in the
+ new environment yields the same result as resolving [X] in the
+ old environment
+ - otherwise, in the new environment [X] resolves to [M.X]
+*)
+val open_signature_of_initially_opened_module:
+ Path.t -> t -> t option
+
+(* Similar to [open_signature] except that sub-modules of the opened modules
+ that are in [hidden_submodules] are not added to the environment. *)
+val open_signature_from_env_summary:
+ Path.t -> t -> hidden_submodules:Misc.StringSet.t -> t option
+
val open_pers_signature: string -> t -> t
(* Insertion by name *)
val report_error: formatter -> error -> unit
-val mark_value_used: t -> string -> value_description -> unit
-val mark_module_used: t -> string -> Location.t -> unit
-val mark_type_used: t -> string -> type_declaration -> unit
+val mark_value_used: string -> value_description -> unit
+val mark_module_used: string -> Location.t -> unit
+val mark_type_used: string -> type_declaration -> unit
type constructor_usage = Positive | Pattern | Privatize
val mark_constructor_used:
- constructor_usage -> t -> string -> type_declaration -> string -> unit
+ constructor_usage -> string -> type_declaration -> string -> unit
val mark_constructor:
constructor_usage -> t -> string -> constructor_description -> unit
val mark_extension_used:
- constructor_usage -> t -> extension_constructor -> string -> unit
+ constructor_usage -> extension_constructor -> string -> unit
val in_signature: bool -> t -> t
-val implicit_coercion: t -> t
val is_in_signature: t -> bool
| Env_cltype (s, id, desc) ->
Env.add_cltype id (Subst.cltype_declaration subst desc)
(env_from_summary s subst)
- | Env_open(s, path) ->
+ | Env_open(s, hidden_submodules, path) ->
let env = env_from_summary s subst in
let path' = Subst.module_path subst path in
- begin match Env.open_signature Asttypes.Override path' env with
+ begin match Env.open_signature_from_env_summary path' env
+ ~hidden_submodules with
| Some env -> env
| None -> assert false
end
open Format
-type t = { stamp: int; name: string; mutable flags: int }
+type t = { stamp: int; name: string; flags: int }
let global_flag = 1
let predef_exn_flag = 2
let create_predef_exn s =
incr currentstamp;
- { name = s; stamp = !currentstamp; flags = predef_exn_flag }
+ { name = s; stamp = !currentstamp;
+ flags = predef_exn_flag lor global_flag }
let create_persistent s =
{ name = s; stamp = 0; flags = global_flag }
let name i = i.name
+let with_name i name = { i with name; }
+
let unique_name i = i.name ^ "_" ^ string_of_int i.stamp
let unique_toplevel_name i = i.name ^ "/" ^ string_of_int i.stamp
let hide i =
{ i with stamp = -1 }
-let make_global i =
- i.flags <- i.flags lor global_flag
-
let global i =
(i.flags land global_flag) <> 0
match i.stamp with
| 0 -> fprintf ppf "%s!" i.name
| -1 -> fprintf ppf "%s#" i.name
- | n -> fprintf ppf "%s/%i%s" i.name n (if global i then "g" else "")
+ | n ->
+ let stampstr =
+ if !Clflags.unique_ids then Printf.sprintf "/%i" n else ""
+ in
+ fprintf ppf "%s%s%s" i.name stampstr (if global i then "g" else "")
type 'a tbl =
Empty
(* Identifiers (unique names) *)
-type t = { stamp: int; name: string; mutable flags: int }
+type t
include Identifiable.S with type t := t
(* Notes:
val create_predef_exn: string -> t
val rename: t -> t
val name: t -> string
+val with_name: t -> string -> t
val unique_name: t -> string
val unique_toplevel_name: t -> string
val persistent: t -> bool
When put in a 'a tbl, this identifier can only be looked
up by name. *)
-val make_global: t -> unit
val global: t -> bool
val is_predef_exn: t -> bool
(function ppf ->
fprintf ppf "but is expected to have type")
| CM_Class_type_mismatch (env, cty1, cty2) ->
- Printtyp.wrap_printing_env env (fun () ->
+ Printtyp.wrap_printing_env ~error:true env (fun () ->
fprintf ppf
"@[The class type@;<1 2>%a@ %s@;<1 2>%a@]"
Printtyp.class_type cty1
[Field_type ld1.ld_id]
end
-let type_declarations ?(equality = false) ~loc env name decl1 id decl2 =
+let type_declarations ?(equality = false) ~loc env ~mark name decl1 id decl2 =
Builtin_attributes.check_deprecated_inclusion
~def:decl1.type_loc
~use:decl2.type_loc
let err = match (decl1.type_kind, decl2.type_kind) with
(_, Type_abstract) -> []
| (Type_variant cstrs1, Type_variant cstrs2) ->
- let mark cstrs usage name decl =
- List.iter
- (fun c ->
- Env.mark_constructor_used usage env name decl
- (Ident.name c.Types.cd_id))
- cstrs
- in
- let usage =
- if decl1.type_private = Private || decl2.type_private = Public
- then Env.Positive else Env.Privatize
- in
- mark cstrs1 usage name decl1;
- if equality then mark cstrs2 Env.Positive (Ident.name id) decl2;
- compare_variants ~loc env decl1.type_params decl2.type_params 1 cstrs1 cstrs2
+ if mark then begin
+ let mark cstrs usage name decl =
+ List.iter
+ (fun c ->
+ Env.mark_constructor_used usage name decl
+ (Ident.name c.Types.cd_id))
+ cstrs
+ in
+ let usage =
+ if decl1.type_private = Private || decl2.type_private = Public
+ then Env.Positive else Env.Privatize
+ in
+ mark cstrs1 usage name decl1;
+ if equality then mark cstrs2 Env.Positive (Ident.name id) decl2
+ end;
+ compare_variants ~loc env decl1.type_params
+ decl2.type_params 1 cstrs1 cstrs2
| (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
- let err = compare_records ~loc env decl1.type_params decl2.type_params
- 1 labels1 labels2 in
+ let err =
+ compare_records ~loc env decl1.type_params
+ decl2.type_params 1 labels1 labels2
+ in
if err <> [] || rep1 = rep2 then err else
[Record_representation (rep2 = Record_float)]
| (Type_open, Type_open) -> []
(* Inclusion between extension constructors *)
-let extension_constructors ~loc env id ext1 ext2 =
- let usage =
- if ext1.ext_private = Private || ext2.ext_private = Public
- then Env.Positive else Env.Privatize
- in
- Env.mark_extension_used usage env ext1 (Ident.name id);
+let extension_constructors ~loc env ~mark id ext1 ext2 =
+ if mark then begin
+ let usage =
+ if ext1.ext_private = Private || ext2.ext_private = Public
+ then Env.Positive else Env.Privatize
+ in
+ Env.mark_extension_used usage ext1 (Ident.name id)
+ end;
let ty1 =
Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil))
in
val type_declarations:
?equality:bool ->
loc:Location.t ->
- Env.t -> string ->
+ Env.t -> mark:bool -> string ->
type_declaration -> Ident.t -> type_declaration -> type_mismatch list
val extension_constructors:
- loc:Location.t ->
- Env.t -> Ident.t ->
+ loc:Location.t -> Env.t -> mark:bool -> Ident.t ->
extension_constructor -> extension_constructor -> bool
(*
val class_types:
exception Error of error list
+type mark =
+ | Mark_both
+ | Mark_positive
+ | Mark_negative
+ | Mark_neither
+
+let negate_mark = function
+ | Mark_both -> Mark_both
+ | Mark_positive -> Mark_negative
+ | Mark_negative -> Mark_positive
+ | Mark_neither -> Mark_neither
+
+let mark_positive = function
+ | Mark_both | Mark_positive -> true
+ | Mark_negative | Mark_neither -> false
+
(* All functions "blah env x1 x2" check that x1 is included in x2,
i.e. that x1 is the type of an implementation that fulfills the
specification x2. If not, Error is raised with a backtrace of the error. *)
(* Inclusion between value descriptions *)
-let value_descriptions ~loc env cxt subst id vd1 vd2 =
+let value_descriptions ~loc env ~mark cxt subst id vd1 vd2 =
Cmt_format.record_value_dependency vd1 vd2;
- Env.mark_value_used env (Ident.name id) vd1;
+ if mark_positive mark then
+ Env.mark_value_used (Ident.name id) vd1;
let vd2 = Subst.value_description subst vd2 in
try
Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2
(* Inclusion between type declarations *)
-let type_declarations ~loc env ?(old_env=env) cxt subst id decl1 decl2 =
- Env.mark_type_used env (Ident.name id) decl1;
+let type_declarations ~loc env ~mark ?(old_env=env) cxt subst id decl1 decl2 =
+ let mark = mark_positive mark in
+ if mark then
+ Env.mark_type_used (Ident.name id) decl1;
let decl2 = Subst.type_declaration subst decl2 in
let err =
- Includecore.type_declarations ~loc env (Ident.name id) decl1 id decl2
+ Includecore.type_declarations ~loc env ~mark
+ (Ident.name id) decl1 id decl2
in
if err <> [] then
raise(Error[cxt, old_env, Type_declarations(id, decl1, decl2, err)])
(* Inclusion between extension constructors *)
-let extension_constructors ~loc env cxt subst id ext1 ext2 =
+let extension_constructors ~loc env ~mark cxt subst id ext1 ext2 =
+ let mark = mark_positive mark in
let ext2 = Subst.extension_constructor subst ext2 in
- if Includecore.extension_constructors ~loc env id ext1 ext2
+ if Includecore.extension_constructors ~loc env ~mark id ext1 ext2
then ()
else raise(Error[cxt, env, Extension_constructors(id, ext1, ext2)])
Return the restriction that transforms a value of the smaller type
into a value of the bigger type. *)
-let rec modtypes ~loc env cxt subst mty1 mty2 =
+let rec modtypes ~loc env ~mark cxt subst mty1 mty2 =
try
- try_modtypes ~loc env cxt subst mty1 mty2
+ try_modtypes ~loc env ~mark cxt subst mty1 mty2
with
Dont_match ->
raise(Error[cxt, env, Module_types(mty1, Subst.modtype subst mty2)])
raise(Error((cxt, env, Module_types(mty1, Subst.modtype subst mty2))
:: reasons))
-and try_modtypes ~loc env cxt subst mty1 mty2 =
+and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
match (mty1, mty2) with
| (Mty_alias(pres1, p1), Mty_alias(pres2, p2)) -> begin
if Env.is_functor_arg p2 env then
Mtype.strengthen ~aliasable:true env
(expand_module_alias env cxt p1) p1
in
- let cc = modtypes ~loc env cxt subst mty1 mty2 in
+ let cc = modtypes ~loc env ~mark cxt subst mty1 mty2 in
match pres1 with
| Mta_present -> cc
| Mta_absent -> Tcoerce_alias (p1, cc)
end
| (Mty_ident p1, _) when may_expand_module_path env p1 ->
- try_modtypes ~loc env cxt subst (expand_module_path env cxt p1) mty2
+ try_modtypes ~loc env ~mark cxt subst
+ (expand_module_path env cxt p1) mty2
| (_, Mty_ident _) ->
- try_modtypes2 ~loc env cxt mty1 (Subst.modtype subst mty2)
+ try_modtypes2 ~loc env ~mark cxt mty1 (Subst.modtype subst mty2)
| (Mty_signature sig1, Mty_signature sig2) ->
- signatures ~loc env cxt subst sig1 sig2
+ signatures ~loc env ~mark cxt subst sig1 sig2
| (Mty_functor(param1, None, res1), Mty_functor(_param2, None, res2)) ->
- begin match modtypes ~loc env (Body param1::cxt) subst res1 res2 with
- Tcoerce_none -> Tcoerce_none
+ begin
+ match modtypes ~loc env ~mark (Body param1::cxt) subst res1 res2 with
+ | Tcoerce_none -> Tcoerce_none
| cc -> Tcoerce_functor (Tcoerce_none, cc)
- end
+ end
| (Mty_functor(param1, Some arg1, res1),
Mty_functor(param2, Some arg2, res2)) ->
let arg2' = Subst.modtype subst arg2 in
- let cc_arg = modtypes ~loc env (Arg param1::cxt) Subst.identity arg2' arg1 in
+ let cc_arg =
+ modtypes ~loc env ~mark:(negate_mark mark)
+ (Arg param1::cxt) Subst.identity arg2' arg1
+ in
let cc_res =
- modtypes ~loc (Env.add_module param1 arg2' env) (Body param1::cxt)
- (Subst.add_module param2 (Pident param1) subst) res1 res2 in
+ modtypes ~loc (Env.add_module param1 arg2' env) ~mark
+ (Body param1::cxt) (Subst.add_module param2 (Pident param1) subst)
+ res1 res2
+ in
begin match (cc_arg, cc_res) with
(Tcoerce_none, Tcoerce_none) -> Tcoerce_none
| _ -> Tcoerce_functor(cc_arg, cc_res)
| (_, _) ->
raise Dont_match
-and try_modtypes2 ~loc env cxt mty1 mty2 =
+and try_modtypes2 ~loc env ~mark cxt mty1 mty2 =
(* mty2 is an identifier *)
match (mty1, mty2) with
(Mty_ident p1, Mty_ident p2)
(Env.normalize_path_prefix None env p2) ->
Tcoerce_none
| (_, Mty_ident p2) when may_expand_module_path env p2 ->
- try_modtypes ~loc env cxt Subst.identity mty1 (expand_module_path env cxt p2)
+ try_modtypes ~loc env ~mark cxt Subst.identity
+ mty1 (expand_module_path env cxt p2)
| (_, _) ->
raise Dont_match
(* Inclusion between signatures *)
-and signatures ~loc env cxt subst sig1 sig2 =
+and signatures ~loc env ~mark cxt subst sig1 sig2 =
(* Environment used to check inclusion of components *)
let new_env =
Env.add_signature sig1 (Env.in_signature true env) in
begin match unpaired with
[] ->
let cc =
- signature_components ~loc env new_env cxt subst
+ signature_components ~loc env ~mark new_env cxt subst
(List.rev paired)
in
if len1 = len2 then (* see PR#5098 *)
(* Inclusion between signature components *)
-and signature_components ~loc old_env env cxt subst paired =
- let comps_rec rem = signature_components ~loc old_env env cxt subst rem in
+and signature_components ~loc old_env ~mark env cxt subst paired =
+ let comps_rec rem =
+ signature_components ~loc old_env ~mark env cxt subst rem
+ in
match paired with
[] -> []
| (Sig_value(id1, valdecl1), Sig_value(_id2, valdecl2), pos) :: rem ->
- let cc = value_descriptions ~loc env cxt subst id1 valdecl1 valdecl2 in
+ let cc =
+ value_descriptions ~loc env ~mark cxt subst id1 valdecl1 valdecl2
+ in
begin match valdecl2.val_kind with
Val_prim _ -> comps_rec rem
| _ -> (pos, cc) :: comps_rec rem
end
| (Sig_type(id1, tydecl1, _), Sig_type(_id2, tydecl2, _), _pos) :: rem ->
- type_declarations ~loc ~old_env env cxt subst id1 tydecl1 tydecl2;
+ type_declarations ~loc ~old_env env ~mark cxt subst id1 tydecl1 tydecl2;
comps_rec rem
| (Sig_typext(id1, ext1, _), Sig_typext(_id2, ext2, _), pos)
:: rem ->
- extension_constructors ~loc env cxt subst id1 ext1 ext2;
+ extension_constructors ~loc env ~mark cxt subst id1 ext1 ext2;
(pos, Tcoerce_none) :: comps_rec rem
| (Sig_module(id1, mty1, _), Sig_module(_id2, mty2, _), pos) :: rem ->
- let cc = module_declarations ~loc env cxt subst id1 mty1 mty2 in
+ let cc = module_declarations ~loc env ~mark cxt subst id1 mty1 mty2 in
(pos, cc) :: comps_rec rem
| (Sig_modtype(id1, info1), Sig_modtype(_id2, info2), _pos) :: rem ->
- modtype_infos ~loc env cxt subst id1 info1 info2;
+ modtype_infos ~loc env ~mark cxt subst id1 info1 info2;
comps_rec rem
| (Sig_class(id1, decl1, _), Sig_class(_id2, decl2, _), pos) :: rem ->
class_declarations ~old_env env cxt subst id1 decl1 decl2;
| _ ->
assert false
-and module_declarations ~loc env cxt subst id1 md1 md2 =
+and module_declarations ~loc env ~mark cxt subst id1 md1 md2 =
Builtin_attributes.check_deprecated_inclusion
~def:md1.md_loc
~use:md2.md_loc
md1.md_attributes md2.md_attributes
(Ident.name id1);
let p1 = Pident id1 in
- Env.mark_module_used env (Ident.name id1) md1.md_loc;
- modtypes ~loc env (Module id1::cxt) subst
+ if mark_positive mark then
+ Env.mark_module_used (Ident.name id1) md1.md_loc;
+ modtypes ~loc env ~mark (Module id1::cxt) subst
(Mtype.strengthen ~aliasable:true env md1.md_type p1) md2.md_type
(* Inclusion between module type specifications *)
-and modtype_infos ~loc env cxt subst id info1 info2 =
+and modtype_infos ~loc env ~mark cxt subst id info1 info2 =
Builtin_attributes.check_deprecated_inclusion
~def:info1.mtd_loc
~use:info2.mtd_loc
(None, None) -> ()
| (Some _, None) -> ()
| (Some mty1, Some mty2) ->
- check_modtype_equiv ~loc env cxt' mty1 mty2
+ check_modtype_equiv ~loc env ~mark cxt' mty1 mty2
| (None, Some mty2) ->
- check_modtype_equiv ~loc env cxt' (Mty_ident(Pident id)) mty2
+ check_modtype_equiv ~loc env ~mark cxt' (Mty_ident(Pident id)) mty2
with Error reasons ->
raise(Error((cxt, env, Modtype_infos(id, info1, info2)) :: reasons))
-and check_modtype_equiv ~loc env cxt mty1 mty2 =
+and check_modtype_equiv ~loc env ~mark cxt mty1 mty2 =
match
- (modtypes ~loc env cxt Subst.identity mty1 mty2,
- modtypes ~loc env cxt Subst.identity mty2 mty1)
+ (modtypes ~loc env ~mark cxt Subst.identity mty1 mty2,
+ modtypes ~loc env ~mark:(negate_mark mark) cxt Subst.identity mty2 mty1)
with
(Tcoerce_none, Tcoerce_none) -> ()
| (_c1, _c2) ->
no_apply path && not (Env.is_functor_arg path env)
let check_modtype_inclusion ~loc env mty1 path1 mty2 =
- try
- let aliasable = can_alias env path1 in
- ignore(modtypes ~loc env [] Subst.identity
- (Mtype.strengthen ~aliasable env mty1 path1) mty2)
- with Error _ ->
- raise Not_found
+ let aliasable = can_alias env path1 in
+ ignore(modtypes ~loc env ~mark:Mark_both [] Subst.identity
+ (Mtype.strengthen ~aliasable env mty1 path1) mty2)
-let _ = Env.check_modtype_inclusion := check_modtype_inclusion
+let () =
+ Env.check_modtype_inclusion := (fun ~loc a b c d ->
+ try (check_modtype_inclusion ~loc a b c d : unit)
+ with Error _ -> raise Not_found)
(* Check that an implementation of a compilation unit meets its
interface. *)
-let compunit env impl_name impl_sig intf_name intf_sig =
+let compunit env ?(mark=Mark_both) impl_name impl_sig intf_name intf_sig =
try
- signatures ~loc:(Location.in_file impl_name) env [] Subst.identity
- impl_sig intf_sig
+ signatures ~loc:(Location.in_file impl_name) env ~mark []
+ Subst.identity impl_sig intf_sig
with Error reasons ->
raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name))
:: reasons))
(* Hide the context and substitution parameters to the outside world *)
-let modtypes ~loc env mty1 mty2 = modtypes ~loc env [] Subst.identity mty1 mty2
-let signatures env sig1 sig2 =
- signatures ~loc:Location.none env [] Subst.identity sig1 sig2
-let type_declarations ~loc env id decl1 decl2 =
- type_declarations ~loc env [] Subst.identity id decl1 decl2
+let modtypes ~loc env ?(mark=Mark_both) mty1 mty2 =
+ modtypes ~loc env ~mark [] Subst.identity mty1 mty2
+let signatures env ?(mark=Mark_both) sig1 sig2 =
+ signatures ~loc:Location.none env ~mark [] Subst.identity sig1 sig2
+let type_declarations ~loc env ?(mark=Mark_both) id decl1 decl2 =
+ type_declarations ~loc env ~mark [] Subst.identity id decl1 decl2
(*
let modtypes env m1 m2 =
fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt
let include_err ppf (cxt, env, err) =
- Printtyp.wrap_printing_env env (fun () ->
+ Printtyp.wrap_printing_env ~error:true env (fun () ->
fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err)
let buffer = ref Bytes.empty
open Types
open Format
+(** Type describing which arguments of an inclusion to consider as used
+ for the usage warnings. [Mark_both] is the default. *)
+type mark =
+ | Mark_both
+ (** Mark definitions used from both arguments *)
+ | Mark_positive
+ (** Mark definitions used from the positive (first) argument *)
+ | Mark_negative
+ (** Mark definitions used from the negative (second) argument *)
+ | Mark_neither
+ (** Do not mark definitions used from either argument *)
+
val modtypes:
- loc:Location.t -> Env.t ->
+ loc:Location.t -> Env.t -> ?mark:mark ->
module_type -> module_type -> module_coercion
-val signatures: Env.t -> signature -> signature -> module_coercion
+val check_modtype_inclusion :
+ loc:Location.t -> Env.t -> Types.module_type -> Path.t -> Types.module_type -> unit
+(** [check_modtype_inclusion ~loc env mty1 path1 mty2] checks that the
+ functor application F(M) is well typed, where mty2 is the type of
+ the argument of F and path1/mty1 is the path/unstrenghened type of M. *)
+
+val signatures: Env.t -> ?mark:mark ->
+ signature -> signature -> module_coercion
val compunit:
- Env.t -> string -> signature -> string -> signature -> module_coercion
+ Env.t -> ?mark:mark -> string -> signature ->
+ string -> signature -> module_coercion
val type_declarations:
- loc:Location.t -> Env.t ->
+ loc:Location.t -> Env.t -> ?mark:mark ->
Ident.t -> type_declaration -> type_declaration -> unit
val print_coercion: formatter -> module_coercion -> unit
let () = Env.strengthen := strengthen
+let rec make_aliases_absent mty =
+ match mty with
+ | Mty_alias(_, p) ->
+ Mty_alias(Mta_absent, p)
+ | Mty_signature sg ->
+ Mty_signature(make_aliases_absent_sig sg)
+ | Mty_functor(param, arg, res) ->
+ Mty_functor(param, arg, make_aliases_absent res)
+ | mty ->
+ mty
+
+and make_aliases_absent_sig sg =
+ match sg with
+ [] -> []
+ | Sig_module(id, md, rs) :: rem ->
+ let str =
+ { md with md_type = make_aliases_absent md.md_type }
+ in
+ Sig_module(id, str, rs) :: make_aliases_absent_sig rem
+ | sigelt :: rem ->
+ sigelt :: make_aliases_absent_sig rem
+
+let scrape_for_type_of env mty =
+ let rec loop env path mty =
+ match mty, path with
+ | Mty_alias(_, path), _ -> begin
+ try
+ let md = Env.find_module path env in
+ loop env (Some path) md.md_type
+ with Not_found -> mty
+ end
+ | mty, Some path ->
+ strengthen ~aliasable:false env mty path
+ | _ -> mty
+ in
+ make_aliases_absent (loop env None mty)
+
(* In nondep_supertype, env is only used for the type it assigns to id.
Hence there is no need to keep env up-to-date by adding the bindings
traversed. *)
in
nondep_mty env Co mty
-let enrich_typedecl env p decl =
+let enrich_typedecl env p id decl =
match decl.type_manifest with
Some _ -> decl
| None ->
try
let orig_decl = Env.find_type p env in
- if orig_decl.type_arity <> decl.type_arity
- then decl
- else {decl with type_manifest =
- Some(Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil)))}
- with Not_found ->
+ if decl.type_arity <> orig_decl.type_arity then
+ decl
+ else
+ let orig_ty =
+ Ctype.reify_univars
+ (Btype.newgenty(Tconstr(p, orig_decl.type_params, ref Mnil)))
+ in
+ let new_ty =
+ Ctype.reify_univars
+ (Btype.newgenty(Tconstr(Pident id, decl.type_params, ref Mnil)))
+ in
+ let env = Env.add_type ~check:false id decl env in
+ Ctype.mcomp env orig_ty new_ty;
+ let orig_ty =
+ Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil))
+ in
+ {decl with type_manifest = Some orig_ty}
+ with Not_found | Ctype.Unify _ ->
+ (* - Not_found: type which was not present in the signature, so we don't
+ have anything to do.
+ - Unify: the current declaration is not compatible with the one we
+ got from the signature. We should just fail now, but then, we could
+ also have failed if the arities of the two decls were different,
+ which we didn't. *)
decl
let rec enrich_modtype env p mty =
and enrich_item env p = function
Sig_type(id, decl, rs) ->
Sig_type(id,
- enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl, rs)
+ enrich_typedecl env (Pdot(p, Ident.name id, nopos)) id decl, rs)
| Sig_module(id, md, rs) ->
Sig_module(id,
{md with
module PathSet = Set.Make (Path)
module PathMap = Map.Make (Path)
-module IdentSet = Set.Make (Ident)
let rec get_prefixes = function
Pident _ -> PathSet.empty
Pident id ->
let ids =
try collect_ids subst bindings (Ident.find_same id bindings)
- with Not_found -> IdentSet.empty
+ with Not_found -> Ident.Set.empty
in
- IdentSet.add id ids
- | _ -> IdentSet.empty
+ Ident.Set.add id ids
+ | _ -> Ident.Set.empty
end
let collect_arg_paths mty =
let it = {type_iterators with it_path; it_signature_item} in
it.it_module_type it mty;
it.it_module_type unmark_iterators mty;
- PathSet.fold (fun p -> IdentSet.union (collect_ids !subst !bindings p))
- !paths IdentSet.empty
+ PathSet.fold (fun p -> Ident.Set.union (collect_ids !subst !bindings p))
+ !paths Ident.Set.empty
-let rec remove_aliases env excl mty =
+let rec remove_aliases_mty env excl mty =
match mty with
Mty_signature sg ->
Mty_signature (remove_aliases_sig env excl sg)
| Mty_alias _ ->
let mty' = Env.scrape_alias env mty in
if mty' = mty then mty else
- remove_aliases env excl mty'
+ remove_aliases_mty env excl mty'
| mty ->
mty
| Sig_module(id, md, rs) :: rem ->
let mty =
match md.md_type with
- Mty_alias _ when IdentSet.mem id excl ->
+ Mty_alias _ when Ident.Set.mem id excl ->
md.md_type
| mty ->
- remove_aliases env excl mty
+ remove_aliases_mty env excl mty
in
Sig_module(id, {md with md_type = mty} , rs) ::
remove_aliases_sig (Env.add_module id mty env) excl rem
| it :: rem ->
it :: remove_aliases_sig env excl rem
-let remove_aliases env sg =
- let excl = collect_arg_paths sg in
- (* PathSet.iter (fun p -> Format.eprintf "%a@ " Printtyp.path p) excl;
- Format.eprintf "@."; *)
- remove_aliases env excl sg
+let scrape_for_type_of ~remove_aliases env mty =
+ if remove_aliases then begin
+ let excl = collect_arg_paths mty in
+ remove_aliases_mty env excl mty
+ end else begin
+ scrape_for_type_of env mty
+ end
(* Lower non-generalizable type variables *)
(* Expand toplevel module type abbreviations
till hitting a "hard" module type (signature, functor,
or abstract module type ident. *)
+val scrape_for_type_of:
+ remove_aliases:bool -> Env.t -> module_type -> module_type
+ (* Expand module aliases *)
val freshen: module_type -> module_type
(* Return an alpha-equivalent copy of the given module type
where bound identifiers are fresh. *)
(* Determine whether a module needs no implementation code,
i.e. consists only of type definitions. *)
val enrich_modtype: Env.t -> Path.t -> module_type -> module_type
-val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration
+val enrich_typedecl: Env.t -> Path.t -> Ident.t -> type_declaration ->
+ type_declaration
val type_paths: Env.t -> Path.t -> module_type -> Path.t list
val contains_type: Env.t -> module_type -> bool
-val remove_aliases: Env.t -> module_type -> module_type
val lower_nongen: int -> module_type -> unit
| Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l)
| Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L)
| Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n)
- | Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0)
+ | Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0 || 1. /. f = neg_infinity)
| Oval_string (_,_, Ostr_bytes) as tree ->
pp_print_char ppf '(';
print_simple_tree ppf tree;
print_private td.otype_private
print_record_decl lbls
| Otyp_sum constrs ->
+ let variants fmt constrs =
+ if constrs = [] then fprintf fmt "|" else
+ fprintf fmt "%a" (print_list print_out_constr
+ (fun ppf -> fprintf ppf "@ | ")) constrs in
fprintf ppf " =%a@;<1 2>%a"
- print_private td.otype_private
- (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
+ print_private td.otype_private variants constrs
| Otyp_open ->
fprintf ppf " =%a .."
print_private td.otype_private
when an "incoherence" is not detected by this check.
*)
-
-let simplify_head_pat p k =
- let rec simplify_head_pat p k =
- match p.pat_desc with
- | Tpat_alias (p,_,_) -> simplify_head_pat p k
- | Tpat_var (_,_) -> omega :: k
- | Tpat_or (p1,p2,_) -> simplify_head_pat p1 (simplify_head_pat p2 k)
- | _ -> p :: k
- in simplify_head_pat p k
-
-let rec simplified_first_col = function
- | [] -> []
- | [] :: _ -> assert false (* the rows are non-empty! *)
- | (p::_) :: rows ->
- simplify_head_pat p (simplified_first_col rows)
-
-(* Given the simplified first column of a matrix, this function first looks for
+(* Given the first column of a simplified matrix, this function first looks for
a "discriminating" pattern on that column (i.e. a non-omega one) and then
check that every other head pattern in the column is coherent with that one.
*)
Array.length lbl1.lbl_all = Array.length lbl2.lbl_all
| Tpat_any, _
| _, Tpat_any
- | Tpat_record ([], _), Tpat_record (_, _)
- | Tpat_record (_, _), Tpat_record ([], _)
+ | Tpat_record ([], _), Tpat_record ([], _)
| Tpat_variant _, Tpat_variant _
| Tpat_array _, Tpat_array _
| Tpat_lazy _, Tpat_lazy _ -> true
Pervasives.compare (float_of_string f1) (float_of_string f2)
| Const_string (s1, _), Const_string (s2, _) ->
String.compare s1 s2
- | _, _ -> Pervasives.compare x y
+ | (Const_int _
+ |Const_char _
+ |Const_string (_, _)
+ |Const_float _
+ |Const_int32 _
+ |Const_int64 _
+ |Const_nativeint _
+ ), _ -> Pervasives.compare x y
let records_args l1 l2 =
(* Invariant: fields are already sorted by Typecore.type_label_a_list *)
if ty.level = Btype.generic_level then ty
else Subst.type_expr Subst.identity ty
-let get_type_path ty tenv =
+let get_constructor_type_path ty tenv =
let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in
match ty.desc with
| Tconstr (path,_,_) -> path
- | _ -> fatal_error "Parmatch.get_type_path"
-
-(*************************************)
-(* Values as patterns pretty printer *)
-(*************************************)
-
-open Format
-;;
-
-let is_cons = function
-| {cstr_name = "::"} -> true
-| _ -> false
-
-let pretty_const c = match c with
-| Const_int i -> Printf.sprintf "%d" i
-| Const_char c -> Printf.sprintf "%C" c
-| Const_string (s, _) -> Printf.sprintf "%S" s
-| Const_float f -> Printf.sprintf "%s" f
-| Const_int32 i -> Printf.sprintf "%ldl" i
-| Const_int64 i -> Printf.sprintf "%LdL" i
-| Const_nativeint i -> Printf.sprintf "%ndn" i
-
-let rec pretty_val ppf v =
- match v.pat_extra with
- (cstr, _loc, _attrs) :: rem ->
- begin match cstr with
- | Tpat_unpack ->
- fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem }
- | Tpat_constraint _ ->
- fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem }
- | Tpat_type _ ->
- fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
- | Tpat_open _ ->
- fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
- end
- | [] ->
- match v.pat_desc with
- | Tpat_any -> fprintf ppf "_"
- | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
- | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
- | Tpat_tuple vs ->
- fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
- | Tpat_construct (_, cstr, []) ->
- fprintf ppf "%s" cstr.cstr_name
- | Tpat_construct (_, cstr, [w]) ->
- fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w
- | Tpat_construct (_, cstr, vs) ->
- let name = cstr.cstr_name in
- begin match (name, vs) with
- ("::", [v1;v2]) ->
- fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2
- | _ ->
- fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs
- end
- | Tpat_variant (l, None, _) ->
- fprintf ppf "`%s" l
- | Tpat_variant (l, Some w, _) ->
- fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
- | Tpat_record (lvs,_) ->
- let filtered_lvs = List.filter
- (function
- | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
- | _ -> true) lvs in
- begin match filtered_lvs with
- | [] -> fprintf ppf "_"
- | (_, lbl, _) :: q ->
- let elision_mark ppf =
- (* we assume that there is no label repetitions here *)
- if Array.length lbl.lbl_all > 1 + List.length q then
- fprintf ppf ";@ _@ "
- else () in
- fprintf ppf "@[{%a%t}@]"
- pretty_lvals filtered_lvs elision_mark
- end
- | Tpat_array vs ->
- fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
- | Tpat_lazy v ->
- fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
- | Tpat_alias (v, x,_) ->
- fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
- | Tpat_or (v,w,_) ->
- fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
-
-and pretty_car ppf v = match v.pat_desc with
-| Tpat_construct (_,cstr, [_ ; _])
- when is_cons cstr ->
- fprintf ppf "(%a)" pretty_val v
-| _ -> pretty_val ppf v
-
-and pretty_cdr ppf v = match v.pat_desc with
-| Tpat_construct (_,cstr, [v1 ; v2])
- when is_cons cstr ->
- fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
-| _ -> pretty_val ppf v
-
-and pretty_arg ppf v = match v.pat_desc with
-| Tpat_construct (_,_,_::_)
-| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v
-| _ -> pretty_val ppf v
-
-and pretty_or ppf v = match v.pat_desc with
-| Tpat_or (v,w,_) ->
- fprintf ppf "%a|@,%a" pretty_or v pretty_or w
-| _ -> pretty_val ppf v
-
-and pretty_vals sep ppf = function
- | [] -> ()
- | [v] -> pretty_val ppf v
- | v::vs ->
- fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs
-
-and pretty_lvals ppf = function
- | [] -> ()
- | [_,lbl,v] ->
- fprintf ppf "%s=%a" lbl.lbl_name pretty_val v
- | (_, lbl,v)::rest ->
- fprintf ppf "%s=%a;@ %a"
- lbl.lbl_name pretty_val v pretty_lvals rest
-
-let top_pretty ppf v =
- fprintf ppf "@[%a@]@?" pretty_val v
-
-
-let pretty_pat p =
- top_pretty Format.str_formatter p ;
- prerr_string (Format.flush_str_formatter ())
-
-type matrix = pattern list list
-
-let pretty_line ps =
- List.iter
- (fun p ->
- top_pretty Format.str_formatter p ;
- prerr_string " <" ;
- prerr_string (Format.flush_str_formatter ()) ;
- prerr_string ">")
- ps
-
-let pretty_matrix (pss : matrix) =
- prerr_endline "begin matrix" ;
- List.iter
- (fun ps ->
- pretty_line ps ;
- prerr_endline "")
- pss ;
- prerr_endline "end matrix"
-
+ | _ -> assert false
(****************************)
(* Utilities for matching *)
with Not_found -> omega)
omegas
-let all_record_args lbls = match lbls with
-| (_,{lbl_all=lbl_all},_)::_ ->
- let t =
- Array.map
- (fun lbl -> mknoloc (Longident.Lident "?temp?"), lbl,omega)
- lbl_all in
- List.iter
- (fun ((_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x)
- lbls ;
- Array.to_list t
-| _ -> fatal_error "Parmatch.all_record_args"
-
-
(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
let rec simple_match_args p1 p2 = match p2.pat_desc with
| Tpat_alias (p2,_,_) -> simple_match_args p1 p2
make_pat (Tpat_lazy omega) q.pat_type q.pat_env
| Tpat_or _ -> fatal_error "Parmatch.normalize_pat"
-(*
- Build normalized (cf. supra) discriminating pattern,
- in the non-data type case
-*)
+(* Consider a pattern matrix whose first column has been simplified to contain
+ only _ or a head constructor
+ | p1, r1...
+ | p2, r2...
+ | p3, r3...
+ | ...
-let discr_pat q pss =
+ We build a normalized /discriminating/ pattern from a pattern [q] by folding
+ over the first column of the matrix, "refining" [q] as we go:
- let rec acc_pat acc pss = match pss with
- ({pat_desc = Tpat_alias (p,_,_)}::ps)::pss ->
- acc_pat acc ((p::ps)::pss)
- | ({pat_desc = Tpat_or (p1,p2,_)}::ps)::pss ->
- acc_pat acc ((p1::ps)::(p2::ps)::pss)
- | ({pat_desc = (Tpat_any | Tpat_var _)}::_)::pss ->
- acc_pat acc pss
- | (({pat_desc = Tpat_tuple _} as p)::_)::_ -> normalize_pat p
- | (({pat_desc = Tpat_lazy _} as p)::_)::_ -> normalize_pat p
- | (({pat_desc = Tpat_record (largs,closed)} as p)::_)::pss ->
- let new_omegas =
- List.fold_right
- (fun (lid, lbl,_) r ->
- try
- let _ = get_field lbl.lbl_pos r in
- r
- with Not_found ->
- (lid, lbl,omega)::r)
- largs (record_arg acc)
- in
- acc_pat
- (make_pat (Tpat_record (new_omegas, closed)) p.pat_type p.pat_env)
- pss
- | _ -> acc in
+ - when we encounter a row starting with [Tpat_tuple] or [Tpat_lazy] then we
+ can stop and return that pattern, as we cannot refine any further. Indeed,
+ these constructors are alone in their signature, so they will subsume
+ whatever other pattern we might find, as well as the pattern we're threading
+ along.
+
+ - when we find a [Tpat_record] then it is a bit more involved: it is also
+ alone in its signature, however it might only be matching a subset of the
+ record fields. We use these fields to refine our accumulator and keep going
+ as another row might match on different fields.
+
+ - rows starting with a wildcard do not bring any information, so we ignore
+ them and keep going
- match normalize_pat q with
- | {pat_desc= (Tpat_any | Tpat_record _)} as q -> acc_pat q pss
- | q -> q
+ - if we encounter anything else (i.e. any other constructor), then we just
+ stop and return our accumulator.
+*)
+let discr_pat q pss =
+ let rec refine_pat acc = function
+ | [] -> acc
+ | (head, _) :: rows ->
+ match head.pat_desc with
+ | Tpat_or _ | Tpat_var _ | Tpat_alias _ -> assert false
+ | Tpat_any -> refine_pat acc rows
+ | Tpat_tuple _ | Tpat_lazy _ -> normalize_pat head
+ | Tpat_record (largs, closed) ->
+ (* N.B. we could make this case "simpler" by refining the record case
+ using [all_record_args].
+ In which case we wouldn't need to fold over the first column for
+ records.
+ However it makes the witness we generate for the exhaustivity warning
+ less pretty. *)
+ let new_omegas =
+ List.fold_right
+ (fun (lid, lbl,_) r ->
+ try
+ let _ = get_field lbl.lbl_pos r in
+ r
+ with Not_found ->
+ (lid, lbl,omega)::r)
+ largs (record_arg acc)
+ in
+ let new_acc =
+ make_pat (Tpat_record (new_omegas, closed)) head.pat_type head.pat_env
+ in
+ refine_pat new_acc rows
+ | _ -> acc
+ in
+ let q = normalize_pat q in
+ (* short-circuiting: clearly if we have anything other than [Tpat_record] or
+ [Tpat_any] to start with, we're not going to be able refine at all. So
+ there's no point going over the matrix. *)
+ match q.pat_desc with
+ | Tpat_any | Tpat_record _ -> refine_pat q pss
+ | _ -> q
(*
In case a matching value is found, set actual arguments
let set_args q r = do_set_args false q r
and set_args_erase_mutable q r = do_set_args true q r
-(* filter pss according to pattern q *)
-let filter_one q pss =
+(* Given a matrix of non-empty rows
+ p1 :: r1...
+ p2 :: r2...
+ p3 :: r3...
+
+ Simplify the first column [p1 p2 p3] by splitting all or-patterns.
+ The result is a list of couples
+ (simple pattern, rest of row)
+ where a "simple pattern" starts with either the catch-all pattern omega (_)
+ or a head constructor.
+
+ For example,
+ x :: r1
+ (Some _) as y :: r2
+ (None as x) as y :: r3
+ (Some x | (None as x)) :: r4
+ becomes
+ (_, r1)
+ (Some _, r2)
+ (None, r3)
+ (Some x, r4)
+ (None, r4)
+ *)
+let simplify_head_pat ~add_column p ps k =
+ let rec simplify_head_pat p ps k =
+ match p.pat_desc with
+ | Tpat_alias (p,_,_) -> simplify_head_pat p ps k
+ | Tpat_var (_,_) -> add_column omega ps k
+ | Tpat_or (p1,p2,_) -> simplify_head_pat p1 ps (simplify_head_pat p2 ps k)
+ | _ -> add_column p ps k
+ in simplify_head_pat p ps k
+
+let rec simplify_first_col = function
+ | [] -> []
+ | [] :: _ -> assert false (* the rows are non-empty! *)
+ | (p::ps) :: rows ->
+ let add_column p ps k = (p, ps) :: k in
+ simplify_head_pat ~add_column p ps (simplify_first_col rows)
+
+
+(* Builds the specialized matrix of [pss] according to pattern [q].
+ See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
+
+ NOTES:
+ - expects [pss] to be a "simplified matrix", cf. [simplify_first_col]
+ - [q] was produced by [discr_pat]
+ - we are polymorphic on the type of matrices we work on, in particular a row
+ might not simply be a [pattern list]. That's why we have the [extend_row]
+ parameter.
+*)
+let build_specialized_submatrix ~extend_row q pss =
let rec filter_rec = function
- ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
- filter_rec ((p::ps)::pss)
- | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
- filter_rec ((p1::ps)::(p2::ps)::pss)
- | (p::ps)::pss ->
+ | ({pat_desc = (Tpat_alias _ | Tpat_or _ | Tpat_var _) }, _) :: _ ->
+ assert false
+ | (p, ps) :: pss ->
if simple_match q p
- then (simple_match_args q p @ ps) :: filter_rec pss
+ then extend_row (simple_match_args q p) ps :: filter_rec pss
else filter_rec pss
| _ -> [] in
filter_rec pss
-(*
- Filter pss in the ``extra case''. This applies :
- - According to an extra constructor (datatype case, non-complete signature).
- - According to anything (all-variables case).
+(* The "default" and "specialized" matrices of a given matrix.
+ See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf .
*)
-let filter_extra pss =
- let rec filter_rec = function
- ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
- filter_rec ((p::ps)::pss)
- | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
- filter_rec ((p1::ps)::(p2::ps)::pss)
- | ({pat_desc = (Tpat_any | Tpat_var(_))} :: qs) :: pss ->
- qs :: filter_rec pss
- | _::pss -> filter_rec pss
- | [] -> [] in
- filter_rec pss
+type 'matrix specialized_matrices = {
+ default : 'matrix;
+ constrs : (pattern * 'matrix) list;
+}
+
+(* Consider a pattern matrix whose first column has been simplified
+ to contain only _ or a head constructor
+ | p1, r1...
+ | p2, r2...
+ | p3, r3...
+ | ...
-(*
- Pattern p0 is the discriminating pattern,
- returns [(q0,pss0) ; ... ; (qn,pssn)]
- where the qi's are simple patterns and the pssi's are
- matched matrices.
-
- NOTES
- * (qi,[]) is impossible.
- * In the case when matching is useless (all-variable case),
- returns []
+ We split this matrix into a list of /specialized/ sub-matrices, one for
+ each head constructor appearing in the first column. For each row whose
+ first column starts with a head constructor, remove this head
+ column, prepend one column for each argument of the constructor,
+ and add the resulting row in the sub-matrix corresponding to this
+ head constructor.
+
+ Rows whose left column is omega (the Any pattern _) may match any
+ head constructor, so they are added to all sub-matrices.
+
+ In the case where all the rows in the matrix have an omega on their first
+ column, then there is only one /specialized/ sub-matrix, formed of all these
+ omega rows.
+ This matrix is also called the /default/ matrix.
+
+ See the documentation of [build_specialized_submatrix] for an explanation of
+ the [extend_row] parameter.
*)
+let build_specialized_submatrices ~extend_row q rows =
+ let extend_group discr p r rs =
+ let r = extend_row (simple_match_args discr p) r in
+ (discr, r :: rs)
+ in
-let filter_all pat0 pss =
+ (* insert a row of head [p] and rest [r] into the right group *)
+ let rec insert_constr p r = function
+ | [] ->
+ (* if no group matched this row, it has a head constructor that
+ was never seen before; add a new sub-matrix for this head *)
+ [extend_group (normalize_pat p) p r []]
+ | (q0,rs) as bd::env ->
+ if simple_match q0 p
+ then extend_group q0 p r rs :: env
+ else bd :: insert_constr p r env
+ in
- let rec insert q qs env =
- match env with
- [] ->
- let q0 = normalize_pat q in
- [q0, [simple_match_args q0 q @ qs]]
- | ((q0,pss) as c)::env ->
- if simple_match q0 q
- then (q0, ((simple_match_args q0 q @ qs) :: pss)) :: env
- else c :: insert q qs env in
-
- let rec filter_rec env = function
- ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
- filter_rec env ((p::ps)::pss)
- | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
- filter_rec env ((p1::ps)::(p2::ps)::pss)
- | ({pat_desc = (Tpat_any | Tpat_var(_))}::_)::pss ->
- filter_rec env pss
- | (p::ps)::pss ->
- filter_rec (insert p ps env) pss
- | _ -> env
-
- and filter_omega env = function
- ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
- filter_omega env ((p::ps)::pss)
- | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
- filter_omega env ((p1::ps)::(p2::ps)::pss)
- | ({pat_desc = (Tpat_any | Tpat_var(_))}::ps)::pss ->
- filter_omega
- (List.map (fun (q,qss) -> (q,(simple_match_args q omega @ ps) :: qss))
- env)
- pss
- | _::pss -> filter_omega env pss
- | [] -> env in
-
- filter_omega
- (filter_rec
- (match pat0.pat_desc with
- (Tpat_record(_) | Tpat_tuple(_) | Tpat_lazy(_)) -> [pat0,[]]
- | _ -> [])
- pss)
- pss
+ (* insert a row of head omega into all groups *)
+ let insert_omega r env =
+ List.map (fun (q0,rs) -> extend_group q0 omega r rs) env
+ in
+
+ let rec form_groups constr_groups omega_tails = function
+ | [] -> (constr_groups, omega_tails)
+ | ({pat_desc=(Tpat_var _|Tpat_alias _|Tpat_or _)},_)::_ -> assert false
+ | ({pat_desc=Tpat_any}, tail) :: rest ->
+ (* note that calling insert_omega here would be wrong
+ as some groups may not have been formed yet, if the
+ first row with this head pattern comes after in the list *)
+ form_groups constr_groups (tail :: omega_tails) rest
+ | (p,r) :: rest ->
+ form_groups (insert_constr p r constr_groups) omega_tails rest
+ in
+
+ let constr_groups, omega_tails =
+ let initial_constr_group =
+ match q.pat_desc with
+ | Tpat_record(_) | Tpat_tuple(_) | Tpat_lazy(_) ->
+ (* [q] comes from [discr_pat], and in this case subsumes any of the
+ patterns we could find on the first column of [rows]. So it is better
+ to use it for our initial environment than any of the normalized
+ pattern we might obtain from the first column. *)
+ [q,[]]
+ | _ -> []
+ in
+ form_groups initial_constr_group [] rows
+ in
+ {
+ default = omega_tails;
+ constrs =
+ (* insert omega rows in all groups *)
+ List.fold_right insert_omega omega_tails constr_groups;
+ }
(* Variant related functions *)
-let rec set_last a = function
- [] -> []
- | [_] -> [a]
- | x::l -> x :: set_last a l
-
-(* mark constructor lines for failure when they are incomplete *)
-let rec mark_partial = function
- ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
- mark_partial ((p::ps)::pss)
- | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
- mark_partial ((p1::ps)::(p2::ps)::pss)
- | ({pat_desc = (Tpat_any | Tpat_var(_))} :: _ as ps) :: pss ->
- ps :: mark_partial pss
- | ps::pss ->
- (set_last zero ps) :: mark_partial pss
- | [] -> []
+let set_last a =
+ let rec loop = function
+ | [] -> assert false
+ | [_] -> [a]
+ | x::l -> x :: loop l
+ in
+ function
+ | (_, []) -> (a, [])
+ | (first, row) -> (first, loop row)
+
+(* mark constructor lines for failure when they are incomplete
+
+ Precondition: the input matrix has been simplified so that its
+ first column only contains _ or head constructors. *)
+let mark_partial =
+ List.map (function
+ | ({pat_desc=(Tpat_var _|Tpat_alias _|Tpat_or _)},_) -> assert false
+ | ({pat_desc = Tpat_any }, _) as ps -> ps
+ | ps -> set_last zero ps
+ )
let close_variant env row =
let row = Btype.row_repr row in
(*
Check whether the first column of env makes up a complete signature or
- not.
+ not. We work on the discriminating patterns of each sub-matrix: they
+ are simplified, and are not omega/Tpat_any.
*)
-
let full_match closing env = match env with
+| ({pat_desc = (Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_or _)},_) :: _ ->
+ (* discriminating patterns are simplified *)
+ assert false
+| [] -> false
| ({pat_desc = Tpat_construct(_,c,_)},_) :: _ ->
if c.cstr_consts < 0 then false (* extensions *)
else List.length env = c.cstr_consts + c.cstr_nonconsts
| ({pat_desc = Tpat_record(_)},_) :: _ -> true
| ({pat_desc = Tpat_array(_)},_) :: _ -> false
| ({pat_desc = Tpat_lazy(_)},_) :: _ -> true
-| ({pat_desc = (Tpat_any|Tpat_var _|Tpat_alias _|Tpat_or _)},_) :: _
-| []
- ->
- assert false
(* Written as a non-fragile matching, PR#7451 originated from a fragile matching below. *)
let should_extend ext env = match ext with
begin match p.pat_desc with
| Tpat_construct
(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},_) ->
- let path = get_type_path p.pat_type p.pat_env in
+ let path = get_constructor_type_path p.pat_type p.pat_env in
Path.same path ext
| Tpat_construct
(_, {cstr_tag=(Cstr_extension _)},_) -> false
done ;
r
-(* build a pattern from a constructor list *)
+(* build a pattern from a constructor description *)
let pat_of_constr ex_pat cstr =
{ex_pat with pat_desc =
Tpat_construct (mknoloc (Longident.Lident "?pat_of_constr?"),
| [x] -> x
| x :: xs -> orify x (orify_many xs)
+(* build an or-pattern from a constructor list *)
let pat_of_constrs ex_pat cstrs =
if cstrs = [] then raise Empty else
orify_many (List.map (pat_of_constr ex_pat) cstrs)
(*
Builds a pattern that is incompatible with all patterns in
- in the first column of env
+ the first column of env
*)
-let some_other_tag = "<some other tag>"
+let some_private_tag = "<some private tag>"
let build_other ext env = match env with
| ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ ->
{lid with txt="*extension*"})) Ctype.none Env.empty
| ({pat_desc = Tpat_construct _} as p,_) :: _ ->
begin match ext with
- | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) ->
- extra_pat
+ | Some ext ->
+ if Path.same ext (get_constructor_type_path p.pat_type p.pat_env) then
+ extra_pat
+ else
+ build_other_constrs env p
| _ ->
build_other_constrs env p
end
[] row.row_fields
with
[] ->
- make_other_pat some_other_tag true
+ let tag =
+ if Btype.row_fixed row then some_private_tag else
+ let rec mktag tag =
+ if List.mem tag tags then mktag (tag ^ "'") else tag in
+ mktag "AnyOtherTag"
+ in make_other_pat tag true
| pat::other_pats ->
List.fold_left
(fun p_res pat ->
| [] -> omega
| _ -> omega
-(*
- Core function :
- Is the last row of pattern matrix pss + qs satisfiable ?
- That is :
- Does there exists at least one value vector, es such that :
- 1- for all ps in pss ps # es (ps and es are not compatible)
- 2- qs <= es (es matches qs)
-*)
-
let rec has_instance p = match p.pat_desc with
| Tpat_variant (l,_,r) when is_absent l r -> false
| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
| q::rem -> has_instance q && has_instances rem
(*
+ Core function :
+ Is the last row of pattern matrix pss + qs satisfiable ?
+ That is :
+ Does there exists at least one value vector, es such that :
+ 1- for all ps in pss ps # es (ps and es are not compatible)
+ 2- qs <= es (es matches qs)
+
+ ---
+
In two places in the following function, we check the coherence of the first
column of (pss + qs).
If it is incoherent, then we exit early saying that (pss + qs) is not
| {pat_desc = Tpat_alias(q,_,_)}::qs ->
satisfiable pss (q::qs)
| {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
- if not (all_coherent (simplified_first_col pss)) then
+ let pss = simplify_first_col pss in
+ if not (all_coherent (first_column pss)) then
false
else begin
- let q0 = discr_pat omega pss in
- match filter_all q0 pss with
- (* first column of pss is made of variables only *)
- | [] -> satisfiable (filter_extra pss) qs
- | constrs ->
- if full_match false constrs then
- List.exists
- (fun (p,pss) ->
- not (is_absent_pat p) &&
- satisfiable pss (simple_match_args p omega @ qs))
- constrs
- else
- satisfiable (filter_extra pss) qs
+ let { default; constrs } =
+ let q0 = discr_pat omega pss in
+ build_specialized_submatrices ~extend_row:(@) q0 pss in
+ if not (full_match false constrs) then
+ satisfiable default qs
+ else
+ List.exists
+ (fun (p,pss) ->
+ not (is_absent_pat p) &&
+ satisfiable pss (simple_match_args p omega @ qs))
+ constrs
end
| {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> false
| q::qs ->
- if not (all_coherent (q :: simplified_first_col pss)) then
+ let pss = simplify_first_col pss in
+ if not (all_coherent (q :: first_column pss)) then
false
else begin
let q0 = discr_pat q pss in
- satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs)
+ satisfiable (build_specialized_submatrix ~extend_row:(@) q0 pss)
+ (simple_match_args q0 q @ qs)
end
-(* Also return the remaining cases, to enable GADT handling
+(* While [satisfiable] only checks whether the last row of [pss + qs] is
+ satisfiable, this function returns the (possibly empty) list of vectors [es]
+ which verify:
+ 1- for all ps in pss, ps # es (ps and es are not compatible)
+ 2- qs <= es (es matches qs)
+
+ This is done to enable GADT handling
For considerations regarding the coherence check, see the comment on
[satisfiable] above. *)
-let rec satisfiables pss qs = match pss with
-| [] -> if has_instances qs then [qs] else []
-| _ ->
- match qs with
- | [] -> []
- | {pat_desc = Tpat_or(q1,q2,_)}::qs ->
- satisfiables pss (q1::qs) @ satisfiables pss (q2::qs)
- | {pat_desc = Tpat_alias(q,_,_)}::qs ->
- satisfiables pss (q::qs)
- | {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
- if not (all_coherent (simplified_first_col pss)) then
- []
- else begin
- let q0 = discr_pat omega pss in
- let wild p =
- List.map (fun qs -> p::qs) (satisfiables (filter_extra pss) qs) in
- match filter_all q0 pss with
- (* first column of pss is made of variables only *)
- | [] ->
- wild omega
- | (p,_)::_ as constrs ->
- let for_constrs () =
- List.flatten (
- List.map
- (fun (p,pss) ->
- if is_absent_pat p then [] else
- List.map (set_args p)
- (satisfiables pss (simple_match_args p omega @ qs)))
- constrs )
- in
- if full_match false constrs then for_constrs () else
- match p.pat_desc with
- Tpat_construct _ ->
- (* activate this code for checking non-gadt constructors *)
- wild (build_other_constrs constrs p) @ for_constrs ()
- | _ ->
- wild omega
- end
- | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> []
- | q::qs ->
- if not (all_coherent (q :: simplified_first_col pss)) then
- []
- else begin
- let q0 = discr_pat q pss in
- List.map (set_args q0)
- (satisfiables (filter_one q0 pss) (simple_match_args q0 q @ qs))
- end
+let rec list_satisfying_vectors pss qs =
+ match pss with
+ | [] -> if has_instances qs then [qs] else []
+ | _ ->
+ match qs with
+ | [] -> []
+ | {pat_desc = Tpat_or(q1,q2,_)}::qs ->
+ list_satisfying_vectors pss (q1::qs) @
+ list_satisfying_vectors pss (q2::qs)
+ | {pat_desc = Tpat_alias(q,_,_)}::qs ->
+ list_satisfying_vectors pss (q::qs)
+ | {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
+ let pss = simplify_first_col pss in
+ if not (all_coherent (first_column pss)) then
+ []
+ else begin
+ let q0 = discr_pat omega pss in
+ let wild default_matrix p =
+ List.map (fun qs -> p::qs)
+ (list_satisfying_vectors default_matrix qs)
+ in
+ match build_specialized_submatrices ~extend_row:(@) q0 pss with
+ | { default; constrs = [] } ->
+ (* first column of pss is made of variables only *)
+ wild default omega
+ | { default; constrs = ((p,_)::_ as constrs) } ->
+ let for_constrs () =
+ List.flatten (
+ List.map (fun (p,pss) ->
+ if is_absent_pat p then
+ []
+ else
+ let witnesses =
+ list_satisfying_vectors pss
+ (simple_match_args p omega @ qs)
+ in
+ List.map (set_args p) witnesses
+ ) constrs
+ )
+ in
+ if full_match false constrs then for_constrs () else
+ begin match p.pat_desc with
+ | Tpat_construct _ ->
+ (* activate this code for checking non-gadt constructors *)
+ wild default (build_other_constrs constrs p)
+ @ for_constrs ()
+ | _ ->
+ wild default omega
+ end
+ end
+ | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> []
+ | q::qs ->
+ let pss = simplify_first_col pss in
+ if not (all_coherent (q :: first_column pss)) then
+ []
+ else begin
+ let q0 = discr_pat q pss in
+ List.map (set_args q0)
+ (list_satisfying_vectors
+ (build_specialized_submatrix ~extend_row:(@) q0 pss)
+ (simple_match_args q0 q @ qs))
+ end
-(*
- Now another satisfiable function that additionally
- supplies an example of a matching value.
+(******************************************)
+(* Look for a row that matches some value *)
+(******************************************)
- This function should be called for exhaustiveness check only.
+(*
+ Useful for seeing if the example of
+ non-matched value can indeed be matched
+ (by a guarded clause)
*)
-type 'a result =
- | Rnone (* No matching value *)
- | Rsome of 'a (* This matching value *)
+let rec do_match pss qs = match qs with
+| [] ->
+ begin match pss with
+ | []::_ -> true
+ | _ -> false
+ end
+| q::qs -> match q with
+ | {pat_desc = Tpat_or (q1,q2,_)} ->
+ do_match pss (q1::qs) || do_match pss (q2::qs)
+ | {pat_desc = Tpat_any} ->
+ let rec remove_first_column = function
+ | (_::ps)::rem -> ps::remove_first_column rem
+ | _ -> []
+ in
+ do_match (remove_first_column pss) qs
+ | _ ->
+ let q0 = normalize_pat q in
+ let pss = simplify_first_col pss in
+ (* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of
+ its first column. *)
+ do_match
+ (build_specialized_submatrix ~extend_row:(@) q0 pss)
+ (simple_match_args q0 q @ qs)
-(*
-let rec try_many f = function
- | [] -> Rnone
- | (p,pss)::rest ->
- match f (p,pss) with
- | Rnone -> try_many f rest
- | r -> r
-*)
+
+type 'a exhaust_result =
+ | No_matching_value
+ | Witnesses of 'a list
let rappend r1 r2 =
match r1, r2 with
- | Rnone, _ -> r2
- | _, Rnone -> r1
- | Rsome l1, Rsome l2 -> Rsome (l1 @ l2)
+ | No_matching_value, _ -> r2
+ | _, No_matching_value -> r1
+ | Witnesses l1, Witnesses l2 -> Witnesses (l1 @ l2)
-let rec try_many_gadt f = function
- | [] -> Rnone
+let rec try_many f = function
+ | [] -> No_matching_value
| (p,pss)::rest ->
- rappend (f (p, pss)) (try_many_gadt f rest)
+ rappend (f (p, pss)) (try_many f rest)
-(*
-let rec exhaust ext pss n = match pss with
-| [] -> Rsome (omegas n)
-| []::_ -> Rnone
-| pss ->
- let q0 = discr_pat omega pss in
- begin match filter_all q0 pss with
- (* first column of pss is made of variables only *)
- | [] ->
- begin match exhaust ext (filter_extra pss) (n-1) with
- | Rsome r -> Rsome (q0::r)
- | r -> r
- end
- | constrs ->
- let try_non_omega (p,pss) =
- if is_absent_pat p then
- Rnone
- else
- match
- exhaust
- ext pss (List.length (simple_match_args p omega) + n - 1)
- with
- | Rsome r -> Rsome (set_args p r)
- | r -> r in
- if
- full_match true false constrs && not (should_extend ext constrs)
- then
- try_many try_non_omega constrs
- else
- (*
- D = filter_extra pss is the default matrix
- as it is included in pss, one can avoid
- recursive calls on specialized matrices,
- Essentially :
- * D exhaustive => pss exhaustive
- * D non-exhaustive => we have a non-filtered value
- *)
- let r = exhaust ext (filter_extra pss) (n-1) in
- match r with
- | Rnone -> Rnone
- | Rsome r ->
- try
- Rsome (build_other ext constrs::r)
- with
- (* cannot occur, since constructors don't make a full signature *)
- | Empty -> fatal_error "Parmatch.exhaust"
- end
-
-let combinations f lst lst' =
- let rec iter2 x =
- function
- [] -> []
- | y :: ys ->
- f x y :: iter2 x ys
- in
- let rec iter =
- function
- [] -> []
- | x :: xs -> iter2 x lst' @ iter xs
- in
- iter lst
-*)
(*
let print_pat pat =
let rec string_of_pat pat =
Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat)
*)
-(* strictly more powerful than exhaust; however, exhaust
- was kept for backwards compatibility *)
-let rec exhaust_gadt (ext:Path.t option) pss n = match pss with
-| [] -> Rsome [omegas n]
-| []::_ -> Rnone
+(*
+ Now another satisfiable function that additionally
+ supplies an example of a matching value.
+
+ This function should be called for exhaustiveness check only.
+*)
+let rec exhaust (ext:Path.t option) pss n = match pss with
+| [] -> Witnesses [omegas n]
+| []::_ -> No_matching_value
| pss ->
- if not (all_coherent (simplified_first_col pss)) then
+ let pss = simplify_first_col pss in
+ if not (all_coherent (first_column pss)) then
(* We're considering an ill-typed branch, we won't actually be able to
produce a well typed value taking that branch. *)
- Rnone
+ No_matching_value
else begin
(* Assuming the first column is ill-typed but considered coherent, we
might end up producing an ill-typed witness of non-exhaustivity
we might fail to warn the user that the matching is fragile. See for
example testsuite/tests/warnings/w04_failure.ml. *)
let q0 = discr_pat omega pss in
- match filter_all q0 pss with
- (* first column of pss is made of variables only *)
- | [] ->
- begin match exhaust_gadt ext (filter_extra pss) (n-1) with
- | Rsome r -> Rsome (List.map (fun row -> q0::row) r)
+ match build_specialized_submatrices ~extend_row:(@) q0 pss with
+ | { default; constrs = [] } ->
+ (* first column of pss is made of variables only *)
+ begin match exhaust ext default (n-1) with
+ | Witnesses r -> Witnesses (List.map (fun row -> q0::row) r)
| r -> r
end
- | constrs ->
+ | { default; constrs } ->
let try_non_omega (p,pss) =
if is_absent_pat p then
- Rnone
+ No_matching_value
else
match
- exhaust_gadt
+ exhaust
ext pss (List.length (simple_match_args p omega) + n - 1)
with
- | Rsome r -> Rsome (List.map (fun row -> (set_args p row)) r)
+ | Witnesses r -> Witnesses (List.map (fun row -> (set_args p row)) r)
| r -> r in
- let before = try_many_gadt try_non_omega constrs in
+ let before = try_many try_non_omega constrs in
if
full_match false constrs && not (should_extend ext constrs)
then
before
else
- (*
- D = filter_extra pss is the default matrix
- as it is included in pss, one can avoid
- recursive calls on specialized matrices,
- Essentially :
- * D exhaustive => pss exhaustive
- * D non-exhaustive => we have a non-filtered value
- *)
- let r = exhaust_gadt ext (filter_extra pss) (n-1) in
+ let r = exhaust ext default (n-1) in
match r with
- | Rnone -> before
- | Rsome r ->
+ | No_matching_value -> before
+ | Witnesses r ->
try
let p = build_other ext constrs in
let dug = List.map (fun tail -> p :: tail) r in
match before with
- | Rnone -> Rsome dug
- | Rsome x -> Rsome (x @ dug)
+ | No_matching_value -> Witnesses dug
+ | Witnesses x -> Witnesses (x @ dug)
with
(* cannot occur, since constructors don't make a full signature *)
| Empty -> fatal_error "Parmatch.exhaust"
- end
+ end
-let exhaust_gadt ext pss n =
- let ret = exhaust_gadt ext pss n in
+let exhaust ext pss n =
+ let ret = exhaust ext pss n in
match ret with
- Rnone -> Rnone
- | Rsome lst ->
- (* The following line is needed to compile stdlib/printf.ml *)
- if lst = [] then Rsome (omegas n) else
+ No_matching_value -> No_matching_value
+ | Witnesses lst ->
let singletons =
List.map
(function
| _ -> assert false)
lst
in
- Rsome [orify_many singletons]
+ Witnesses [orify_many singletons]
(*
Another exhaustiveness check, enforcing variant typing.
| [] -> false
| []::_ -> true
| pss ->
- if not (all_coherent (simplified_first_col pss)) then
+ let pss = simplify_first_col pss in
+ if not (all_coherent (first_column pss)) then
true
else begin
let q0 = discr_pat omega pss in
- match filter_all q0 pss with
- [] -> pressure_variants tdefs (filter_extra pss)
- | constrs ->
+ match build_specialized_submatrices ~extend_row:(@) q0 pss with
+ | { default; constrs = [] } -> pressure_variants tdefs default
+ | { default; constrs } ->
let rec try_non_omega = function
- (_p,pss) :: rem ->
+ | (_p,pss) :: rem ->
let ok = pressure_variants tdefs pss in
+ (* The order below matters : we want [pressure_variants] to be
+ called on all the specialized submatrices because we might
+ close some variant in any of them regardless of whether [ok]
+ is true for [pss] or not *)
try_non_omega rem && ok
| [] -> true
in
if full_match (tdefs=None) constrs then
try_non_omega constrs
else if tdefs = None then
- pressure_variants None (filter_extra pss)
+ pressure_variants None default
else
let full = full_match true constrs in
let ok =
- if full then try_non_omega constrs
- else try_non_omega (filter_all q0 (mark_partial pss))
+ if full then
+ try_non_omega constrs
+ else begin
+ let { constrs = partial_constrs; _ } =
+ build_specialized_submatrices ~extend_row:(@) q0
+ (mark_partial pss)
+ in
+ try_non_omega partial_constrs
+ end
in
begin match constrs, tdefs with
({pat_desc=Tpat_variant _} as p,_):: _, Some env ->
let row = row_of_pat p in
if Btype.row_fixed row
- || pressure_variants None (filter_extra pss) then ()
+ || pressure_variants None default then ()
else close_variant env row
| _ -> ()
end;
- left -> elements not to be processed,
- right -> elements to be processed
*)
-type 'a row = {no_ors : 'a list ; ors : 'a list ; active : 'a list}
-
+type usefulness_row =
+ {no_ors : pattern list ; ors : pattern list ; active : pattern list}
(*
let pretty_row {ors=ors ; no_ors=no_ors; active=active} =
let push_or_column rs = List.map push_or rs
and push_no_or_column rs = List.map push_no_or rs
-(* Those are adaptations of the previous homonymous functions that
- work on the current column, instead of the first column
-*)
-
-let discr_pat q rs =
- discr_pat q (List.map (fun r -> r.active) rs)
-
-let filter_one q rs =
- let rec filter_rec rs = match rs with
+let rec simplify_first_usefulness_col = function
| [] -> []
- | r::rem ->
- match r.active with
- | [] -> assert false
- | {pat_desc = Tpat_alias(p,_,_)}::ps ->
- filter_rec ({r with active = p::ps}::rem)
- | {pat_desc = Tpat_or(p1,p2,_)}::ps ->
- filter_rec
- ({r with active = p1::ps}::
- {r with active = p2::ps}::
- rem)
- | p::ps ->
- if simple_match q p then
- {r with active=simple_match_args q p @ ps} :: filter_rec rem
- else
- filter_rec rem in
- filter_rec rs
-
+ | row :: rows ->
+ match row.active with
+ | [] -> assert false (* the rows are non-empty! *)
+ | p :: ps ->
+ let add_column p ps k =
+ (p, { row with active = ps }) :: k in
+ simplify_head_pat ~add_column p ps
+ (simplify_first_usefulness_col rows)
(* Back to normal matrices *)
let make_vector r = List.rev r.no_ors
The idea is to first look for or patterns (recursive case), then
check or-patterns argument usefulness (terminal case)
*)
-let rec simplified_first_usefulness_col = function
- | [] -> []
- | row :: rows ->
- match row.active with
- | [] -> assert false (* the rows are non-empty! *)
- | p :: _ -> simplify_head_pat p (simplified_first_usefulness_col rows)
let rec every_satisfiables pss qs = match qs.active with
| [] ->
Unused
| _ ->
(* standard case, filter matrix *)
- (* The handling of incoherent matrices is kept in line with
+ let pss = simplify_first_usefulness_col pss in
+ (* The handling of incoherent matrices is kept in line with
[satisfiable] *)
- if not (all_coherent (uq :: simplified_first_usefulness_col pss)) then
+ if not (all_coherent (uq :: first_column pss)) then
Unused
else begin
let q0 = discr_pat q pss in
every_satisfiables
- (filter_one q0 pss)
+ (build_specialized_submatrix q0 pss
+ ~extend_row:(fun ps r -> { r with active = ps @ r.active }))
{qs with active=simple_match_args q0 q @ rem}
end
end
| {c_guard=Some _} :: rem -> initial_matrix rem
| {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem
-(******************************************)
-(* Look for a row that matches some value *)
-(******************************************)
-
(*
- Useful for seeing if the example of
- non-matched value can indeed be matched
- (by a guarded clause)
+ Build up a working pattern matrix by keeping
+ only the patterns which are guarded
*)
+let rec initial_only_guarded = function
+ | [] -> []
+ | { c_guard = None; _} :: rem ->
+ initial_only_guarded rem
+ | { c_lhs = pat; _ } :: rem ->
+ [pat] :: initial_only_guarded rem
-
-exception NoGuard
-
-let rec initial_all no_guard = function
- | [] ->
- if no_guard then
- raise NoGuard
- else
- []
- | {c_lhs=pat; c_guard; _} :: rem ->
- ([pat], pat.pat_loc) :: initial_all (no_guard && c_guard = None) rem
-
-
-let rec do_filter_var = function
- | (_::ps,loc)::rem -> (ps,loc)::do_filter_var rem
- | _ -> []
-
-let do_filter_one q pss =
- let rec filter_rec = function
- | ({pat_desc = Tpat_alias(p,_,_)}::ps,loc)::pss ->
- filter_rec ((p::ps,loc)::pss)
- | ({pat_desc = Tpat_or(p1,p2,_)}::ps,loc)::pss ->
- filter_rec ((p1::ps,loc)::(p2::ps,loc)::pss)
- | (p::ps,loc)::pss ->
- if simple_match q p
- then (simple_match_args q p @ ps, loc) :: filter_rec pss
- else filter_rec pss
- | _ -> [] in
- filter_rec pss
-
-let rec do_match pss qs = match qs with
-| [] ->
- begin match pss with
- | ([],loc)::_ -> Some loc
- | _ -> None
- end
-| q::qs -> match q with
- | {pat_desc = Tpat_or (q1,q2,_)} ->
- begin match do_match pss (q1::qs) with
- | None -> do_match pss (q2::qs)
- | r -> r
- end
- | {pat_desc = Tpat_any} ->
- do_match (do_filter_var pss) qs
- | _ ->
- let q0 = normalize_pat q in
- (* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of
- its first column. *)
- do_match (do_filter_one q0 pss) (simple_match_args q0 q @ qs)
-
-
-let check_partial_all v casel =
- try
- let pss = initial_all true casel in
- do_match pss [v]
- with
- | NoGuard -> None
-
(************************)
(* Exhaustiveness check *)
(************************)
(* Build an untyped or-pattern from its expected type *)
let ppat_of_type env ty =
match pats_of_type env ty with
- [{pat_desc = Tpat_any}] ->
+ | [] -> raise Empty
+ | [{pat_desc = Tpat_any}] ->
(Conv.mkpat Parsetree.Ppat_any, Hashtbl.create 0, Hashtbl.create 0)
| pats ->
Conv.conv (orify_many pats)
-let do_check_partial ?pred exhaust loc casel pss = match pss with
+let do_check_partial ~pred loc casel pss = match pss with
| [] ->
(*
This can occur
Partial
| ps::_ ->
begin match exhaust None pss (List.length ps) with
- | Rnone -> Total
- | Rsome [u] ->
+ | No_matching_value -> Total
+ | Witnesses [u] ->
let v =
- match pred with
- | Some pred ->
- let (pattern,constrs,labels) = Conv.conv u in
- let u' = pred constrs labels pattern in
- (* pretty_pat u;
- begin match u' with
- None -> prerr_endline ": impossible"
- | Some _ -> prerr_endline ": possible"
- end; *)
- u'
- | None -> Some u
+ let (pattern,constrs,labels) = Conv.conv u in
+ let u' = pred constrs labels pattern in
+ (* pretty_pat u;
+ begin match u' with
+ None -> prerr_endline ": impossible"
+ | Some _ -> prerr_endline ": possible"
+ end; *)
+ u'
in
begin match v with
None -> Total
let errmsg =
try
let buf = Buffer.create 16 in
- let fmt = formatter_of_buffer buf in
- top_pretty fmt v;
- begin match check_partial_all v casel with
- | None -> ()
- | Some _ ->
- (* This is 'Some loc', where loc is the location of
- a possibly matching clause.
- Forget about loc, because printing two locations
- is a pain in the top-level *)
- Buffer.add_string buf
- "\n(However, some guarded clause may match this value.)"
- end;
+ let fmt = Format.formatter_of_buffer buf in
+ Printpat.top_pretty fmt v;
+ if do_match (initial_only_guarded casel) [v] then
+ Buffer.add_string buf
+ "\n(However, some guarded clause may match this value.)";
if contains_extension v then
Buffer.add_string buf
"\nMatching over values of extensible variant types \
fatal_error "Parmatch.check_partial"
end
-(*
-let do_check_partial_normal loc casel pss =
- do_check_partial exhaust loc casel pss
- *)
-
-let do_check_partial_gadt pred loc casel pss =
- do_check_partial ~pred exhaust_gadt loc casel pss
-
-
-
(*****************)
(* Fragile check *)
(*****************)
let rec collect_paths_from_pat r p = match p.pat_desc with
| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},ps)
->
- let path = get_type_path p.pat_type p.pat_env in
+ let path = get_constructor_type_path p.pat_type p.pat_env in
List.fold_left
collect_paths_from_pat
(if extendable_path path then add_path path r else r)
the type is extended.
*)
-let do_check_fragile_param exhaust loc casel pss =
+let do_check_fragile loc casel pss =
let exts =
List.fold_left
(fun r c -> collect_paths_from_pat r c.c_lhs)
List.iter
(fun ext ->
match exhaust (Some ext) pss (List.length ps) with
- | Rnone ->
+ | No_matching_value ->
Location.prerr_warning
loc
(Warnings.Fragile_match (Path.name ext))
- | Rsome _ -> ())
+ | Witnesses _ -> ())
exts
-(*let do_check_fragile_normal = do_check_fragile_param exhaust*)
-let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt
-
(********************************)
(* Exported unused clause check *)
(********************************)
(* Do not warn for unused [pat -> .] *)
if r = Unused && refute then () else
let r =
- (* Do not refine if there are no other lines *)
+ (* Do not refine if either:
+ - we already know the clause is unused
+ - the clause under consideration is not a refutation clause
+ and either:
+ + there are no other lines
+ + we do not care whether the types prevent this clause to be
+ reached.
+ If the clause under consideration *is* a refutation clause
+ then we do need to check more carefully whether it can be
+ refuted or not. *)
let skip =
r = Unused || (not refute && pref = []) ||
not(refute || Warnings.is_active Warnings.Unreachable_case) in
if skip then r else
(* Then look for empty patterns *)
- let sfs = satisfiables pss qs in
+ let sfs = list_satisfying_vectors pss qs in
if sfs = [] then Unused else
let sfs =
List.map (function [u] -> u | _ -> assert false) sfs in
p.pat_loc Warnings.Unused_pat)
ps
| Used -> ()
- with Empty | Not_found | NoGuard -> assert false
+ with Empty | Not_found -> assert false
end ;
if c_guard <> None then
on exhaustive matches only.
*)
-let check_partial_param do_check_partial do_check_fragile loc casel =
- let pss = initial_matrix casel in
- let pss = get_mins le_pats pss in
- let total = do_check_partial loc casel pss in
- if
- total = Total && Warnings.is_active (Warnings.Fragile_match "")
- then begin
- do_check_fragile loc casel pss
- end ;
- total
-
-(*let check_partial =
- check_partial_param
- do_check_partial_normal
- do_check_fragile_normal*)
-
-let check_partial_gadt pred loc casel =
- check_partial_param (do_check_partial_gadt pred)
- do_check_fragile_gadt loc casel
-
+let check_partial pred loc casel =
+ let pss = initial_matrix casel in
+ let pss = get_mins le_pats pss in
+ let total = do_check_partial ~pred loc casel pss in
+ if
+ total = Total && Warnings.is_active (Warnings.Fragile_match "")
+ then begin
+ do_check_fragile loc casel pss
+ end ;
+ total
(*************************************)
(* Ambiguous variable in or-patterns *)
to a specific guard.
*)
-module IdSet = Set.Make(Ident)
-
-let pattern_vars p = IdSet.of_list (Typedtree.pat_bound_idents p)
+let pattern_vars p = Ident.Set.of_list (Typedtree.pat_bound_idents p)
(* Row for ambiguous variable search,
- unseen is the traditional pattern row,
- seen is a list of position bindings *)
-
-type amb_row = { unseen : pattern list ; seen : IdSet.t list; }
-
-
-(* Push binding variables now *)
-
-let rec do_push r p ps seen k = match p.pat_desc with
-| Tpat_alias (p,x,_) -> do_push (IdSet.add x r) p ps seen k
-| Tpat_var (x,_) ->
- (omega,{ unseen = ps; seen=IdSet.add x r::seen; })::k
-| Tpat_or (p1,p2,_) ->
- do_push r p1 ps seen (do_push r p2 ps seen k)
-| _ ->
- (p,{ unseen = ps; seen = r::seen; })::k
-
-let rec push_vars = function
- | [] -> []
- | { unseen = [] }::_ -> assert false
- | { unseen = p::ps; seen; }::rem ->
- do_push IdSet.empty p ps seen (push_vars rem)
-
-let collect_stable = function
- | [] -> assert false
- | { seen=xss; _}::rem ->
- let rec c_rec xss = function
- | [] -> xss
- | {seen=yss; _}::rem ->
- let xss = List.map2 IdSet.inter xss yss in
- c_rec xss rem in
- let inters = c_rec xss rem in
- List.fold_left IdSet.union IdSet.empty inters
-
-
-(*********************************************)
-(* Filtering utilities for our specific rows *)
-(*********************************************)
-
-(* Take a pattern matrix as a list (rows) of lists (columns) of patterns
- | p1, p2, .., pn
- | q1, q2, .., qn
- | r1, r2, .., rn
- | ...
-
- We split this matrix into a list of sub-matrices, one for each head
- constructor appearing in the leftmost column. For each row whose
- left column starts with a head constructor, remove this head
- column, prepend one column for each argument of the constructor,
- and add the resulting row in the sub-matrix corresponding to this
- head constructor.
-
- Rows whose left column is omega (the Any pattern _) may match any
- head constructor, so they are added to all groups.
-
- The list of sub-matrices is represented as a list of pair
- (head constructor, submatrix)
+ row is the traditional pattern row,
+ varsets contain a list of head variable sets (varsets)
+
+ A given varset contains all the variables that appeared at the head
+ of a pattern in the row at some point during traversal: they would
+ all be bound to the same value at matching time. On the contrary,
+ two variables of different varsets appeared at different places in
+ the pattern and may be bound to distinct sub-parts of the matched
+ value.
+
+ All rows of a (sub)matrix have rows of the same length,
+ but also varsets of the same length.
+
+ Varsets are populated when simplifying the first column
+ -- the variables of the head pattern are collected in a new varset.
+ For example,
+ { row = x :: r1; varsets = s1 }
+ { row = (Some _) as y :: r2; varsets = s2 }
+ { row = (None as x) as y :: r3; varsets = s3 }
+ { row = (Some x | (None as x)) :: r4 with varsets = s4 }
+ becomes
+ (_, { row = r1; varsets = {x} :: s1 })
+ (Some _, { row = r2; varsets = {y} :: s2 })
+ (None, { row = r3; varsets = {x, y} :: s3 })
+ (Some x, { row = r4; varsets = {} :: s4 })
+ (None, { row = r4; varsets = {x} :: s4 })
*)
+type amb_row = { row : pattern list ; varsets : Ident.Set.t list; }
-let filter_all =
- (* the head constructor (as a pattern with omega arguments) of
- a pattern *)
- let discr_head pat =
- match pat.pat_desc with
- | Tpat_record (lbls, closed) ->
- (* a partial record pattern { f1 = p1; f2 = p2; _ }
- needs to be expanded, otherwise matching against this head
- would drop the pattern arguments for non-mentioned fields *)
- let lbls = all_record_args lbls in
- normalize_pat { pat with pat_desc = Tpat_record (lbls, closed) }
- | _ -> normalize_pat pat
- in
-
- (* insert a row of head [p] and rest [r] into the right group *)
- let rec insert p r env = match env with
- | [] ->
- (* if no group matched this row, it has a head constructor that
- was never seen before; add a new sub-matrix for this head *)
- let p0 = discr_head p in
- [p0,[{ r with unseen = simple_match_args p0 p @ r.unseen }]]
- | (q0,rs) as bd::env ->
- if simple_match q0 p then begin
- let r = { r with unseen = simple_match_args q0 p@r.unseen; } in
- (q0,r::rs)::env
- end
- else bd::insert p r env in
-
- (* insert a row of head omega into all groups *)
- let insert_omega r env =
- List.map
- (fun (q0,rs) ->
- let r =
- { r with unseen = simple_match_args q0 omega @ r.unseen; } in
- (q0,r::rs))
- env
- in
-
- let rec filter_rec env = function
- | [] -> env
- | ({pat_desc=(Tpat_var _|Tpat_alias _|Tpat_or _)},_)::_ -> assert false
- | ({pat_desc=Tpat_any}, _)::rs -> filter_rec env rs
- | (p,r)::rs -> filter_rec (insert p r env) rs in
+let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k =
+ let rec simpl head_bound_variables varsets p ps k =
+ match p.pat_desc with
+ | Tpat_alias (p,x,_) ->
+ simpl (Ident.Set.add x head_bound_variables) varsets p ps k
+ | Tpat_var (x,_) ->
+ let rest_of_the_row =
+ { row = ps; varsets = Ident.Set.add x head_bound_variables :: varsets; }
+ in
+ add_column omega rest_of_the_row k
+ | Tpat_or (p1,p2,_) ->
+ simpl head_bound_variables varsets p1 ps
+ (simpl head_bound_variables varsets p2 ps k)
+ | _ ->
+ add_column p { row = ps; varsets = head_bound_variables :: varsets; } k
+ in simpl head_bound_variables varsets p ps k
- let rec filter_omega env = function
- | [] -> env
- | ({pat_desc=(Tpat_var _|Tpat_alias _|Tpat_or _)},_)::_ -> assert false
- | ({pat_desc=Tpat_any},r)::rs -> filter_omega (insert_omega r env) rs
- | _::rs -> filter_omega env rs in
+(*
+ To accurately report ambiguous variables, one must consider
+ that previous clauses have already matched some values.
+ Consider for example:
+
+ | (Foo x, Foo y) -> ...
+ | ((Foo x, _) | (_, Foo x)) when bar x -> ...
+
+ The second line taken in isolation uses an unstable variable,
+ but the discriminating values, of the shape [(Foo v1, Foo v2)],
+ would all be filtered by the line above.
+
+ To track this information, the matrices we analyze contain both
+ *positive* rows, that describe the rows currently being analyzed
+ (of type Varsets.row, so that their varsets are tracked) and
+ *negative rows*, that describe the cases already matched against.
+
+ The values matched by a signed matrix are the values matched by
+ some of the positive rows but none of the negative rows. In
+ particular, a variable is stable if, for any value not matched by
+ any of the negative rows, the environment captured by any of the
+ matching positive rows is identical.
+*)
+type ('a, 'b) signed = Positive of 'a | Negative of 'b
- fun rs ->
- (* first insert the rows with head constructors,
- to get the definitive list of groups *)
- let env = filter_rec [] rs in
- (* then add the omega rows to all groups *)
- filter_omega env rs
+let rec simplify_first_amb_col = function
+ | [] -> []
+ | (Negative [] | Positive { row = []; _ }) :: _ -> assert false
+ | Negative (n :: ns) :: rem ->
+ let add_column n ns k = (n, Negative ns) :: k in
+ simplify_head_pat
+ ~add_column n ns (simplify_first_amb_col rem)
+ | Positive { row = p::ps; varsets; }::rem ->
+ let add_column p ps k = (p, Positive ps) :: k in
+ simplify_head_amb_pat
+ Ident.Set.empty varsets
+ ~add_column p ps (simplify_first_amb_col rem)
(* Compute stable bindings *)
-let rec do_stable rs = match rs with
-| [] -> assert false (* No empty matrix *)
-| { unseen=[]; _ }::_ ->
- collect_stable rs
-| _ ->
- let rs = push_vars rs in
- if not (all_coherent (first_column rs)) then begin
- (* If the first column is incoherent, then all the variables of this
- matrix are stable. *)
- List.fold_left (fun acc (_, { seen; _ }) ->
- List.fold_left IdSet.union acc seen
- ) IdSet.empty rs
- end else begin
- (* If the column is ill-typed but deemed coherent, we might spuriously
- warn about some variables being unstable.
- As sad as that might be, the warning can be silenced by splitting the
- or-pattern... *)
- match filter_all rs with
- | [] ->
- do_stable (List.map snd rs)
- | (_,rs)::env ->
- List.fold_left
- (fun xs (_,rs) -> IdSet.inter xs (do_stable rs))
- (do_stable rs) env
- end
-
-let stable p = do_stable [{unseen=[p]; seen=[];}]
+type stable_vars =
+ | All
+ | Vars of Ident.Set.t
+
+let stable_inter sv1 sv2 = match sv1, sv2 with
+ | All, sv | sv, All -> sv
+ | Vars s1, Vars s2 -> Vars (Ident.Set.inter s1 s2)
+
+let reduce f = function
+| [] -> invalid_arg "reduce"
+| x::xs -> List.fold_left f x xs
+
+let rec matrix_stable_vars m = match m with
+ | [] -> All
+ | ((Positive {row = []; _} | Negative []) :: _) as empty_rows ->
+ let exception Negative_empty_row in
+ (* if at least one empty row is negative, the matrix matches no value *)
+ let get_varsets = function
+ | Negative n ->
+ (* All rows have the same number of columns;
+ if the first row is empty, they all are. *)
+ assert (n = []);
+ raise Negative_empty_row
+ | Positive p ->
+ assert (p.row = []);
+ p.varsets in
+ begin match List.map get_varsets empty_rows with
+ | exception Negative_empty_row -> All
+ | rows_varsets ->
+ let stables_in_varsets =
+ reduce (List.map2 Ident.Set.inter) rows_varsets in
+ (* The stable variables are those stable at any position *)
+ Vars
+ (List.fold_left Ident.Set.union Ident.Set.empty stables_in_varsets)
+ end
+ | m ->
+ let is_negative = function
+ | Negative _ -> true
+ | Positive _ -> false in
+ if List.for_all is_negative m then
+ (* optimization: quit early if there are no positive rows.
+ This may happen often when the initial matrix has many
+ negative cases and few positive cases (a small guarded
+ clause after a long list of clauses) *)
+ All
+ else begin
+ let m = simplify_first_amb_col m in
+ if not (all_coherent (first_column m)) then
+ All
+ else begin
+ (* If the column is ill-typed but deemed coherent, we might
+ spuriously warn about some variables being unstable.
+ As sad as that might be, the warning can be silenced by
+ splitting the or-pattern... *)
+ let submatrices =
+ let extend_row columns = function
+ | Negative r -> Negative (columns @ r)
+ | Positive r -> Positive { r with row = columns @ r.row } in
+ let q0 = discr_pat omega m in
+ let { default; constrs } =
+ build_specialized_submatrices ~extend_row q0 m in
+ let non_default = List.map snd constrs in
+ if full_match false constrs
+ then non_default
+ else default :: non_default in
+ (* A stable variable must be stable in each submatrix. *)
+ let submat_stable = List.map matrix_stable_vars submatrices in
+ List.fold_left stable_inter All submat_stable
+ end
+ end
+let pattern_stable_vars ns p =
+ matrix_stable_vars
+ (List.fold_left (fun m n -> Negative n :: m)
+ [Positive {varsets = []; row = [p]}] ns)
(* All identifier paths that appear in an expression that occurs
as a clause right hand side or guard.
*)
let all_rhs_idents exp =
- let ids = ref IdSet.empty in
+ let ids = ref Ident.Set.empty in
let module Iterator = TypedtreeIter.MakeIterator(struct
include TypedtreeIter.DefaultIteratorArgument
let enter_expression exp = match exp.exp_desc with
| Texp_ident (path, _lid, _descr) ->
List.iter
- (fun id -> ids := IdSet.add id !ids)
+ (fun id -> ids := Ident.Set.add id !ids)
(Path.heads path)
| _ -> ()
{mod_desc=
Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)},
_) ->
- assert (IdSet.mem id_exp !ids) ;
- if not (IdSet.mem id_mod !ids) then begin
- ids := IdSet.remove id_exp !ids
+ assert (Ident.Set.mem id_exp !ids) ;
+ if not (Ident.Set.mem id_mod !ids) then begin
+ ids := Ident.Set.remove id_exp !ids
end
| _ -> assert false
end
let warn0 = Ambiguous_pattern [] in
fun cases ->
if is_active warn0 then
- List.iter
- (fun case -> match case with
- | { c_guard=None ; _} -> ()
+ let check_case ns case = match case with
+ | { c_lhs = p; c_guard=None ; _} -> [p]::ns
| { c_lhs=p; c_guard=Some g; _} ->
let all =
- IdSet.inter (pattern_vars p) (all_rhs_idents g) in
- if not (IdSet.is_empty all) then begin
- let st = stable p in
- let ambiguous = IdSet.diff all st in
- if not (IdSet.is_empty ambiguous) then begin
- let pps = IdSet.elements ambiguous |> List.map Ident.name in
- let warn = Ambiguous_pattern pps in
- Location.prerr_warning p.pat_loc warn
- end
- end)
- cases
+ Ident.Set.inter (pattern_vars p) (all_rhs_idents g) in
+ if not (Ident.Set.is_empty all) then begin
+ match pattern_stable_vars ns p with
+ | All -> ()
+ | Vars stable ->
+ let ambiguous = Ident.Set.diff all stable in
+ if not (Ident.Set.is_empty ambiguous) then begin
+ let pps =
+ Ident.Set.elements ambiguous |> List.map Ident.name in
+ let warn = Ambiguous_pattern pps in
+ Location.prerr_warning p.pat_loc warn
+ end
+ end;
+ ns
+ in
+ ignore (List.fold_left check_case [] cases)
(* *)
(**************************************************************************)
-(* Detection of partial matches and unused match cases. *)
+(** Detection of partial matches and unused match cases. *)
+
open Asttypes
open Typedtree
open Types
-val pretty_const : constant -> string
-val top_pretty : Format.formatter -> pattern -> unit
-val pretty_pat : pattern -> unit
-val pretty_line : pattern list -> unit
-val pretty_matrix : pattern list list -> unit
-
val omega : pattern
+(** aka. "Tpat_any" or "_" *)
+
val omegas : int -> pattern list
+(** [List.init (fun _ -> omega)] *)
+
val omega_list : 'a list -> pattern list
+(** [List.map (fun _ -> omega)] *)
+
val normalize_pat : pattern -> pattern
-val all_record_args :
- (Longident.t loc * label_description * pattern) list ->
- (Longident.t loc * label_description * pattern) list
+(** Keep only the "head" of a pattern: all arguments are replaced by [omega], so
+ are variables. *)
+
val const_compare : constant -> constant -> int
+(** [const_compare c1 c2] compares the actual values represented by [c1] and
+ [c2], while simply using [Pervasives.compare] would compare the
+ representations.
+
+ cf. MPR#5758 *)
val le_pat : pattern -> pattern -> bool
+(** [le_pat p q] means: forall V, V matches q implies V matches p *)
+
val le_pats : pattern list -> pattern list -> bool
+(** [le_pats (p1 .. pm) (q1 .. qn)] means: forall i <= m, [le_pat pi qi] *)
-(* Exported compatibility functor, abstracted over constructor equality *)
+(** Exported compatibility functor, abstracted over constructor equality *)
module Compat :
functor
(Constr: sig
end
exception Empty
+
val lub : pattern -> pattern -> pattern
+(** [lub p q] is a pattern that matches all values matched by [p] and [q].
+ May raise [Empty], when [p] and [q] are not compatible. *)
+
val lubs : pattern list -> pattern list -> pattern list
+(** [lubs [p1; ...; pn] [q1; ...; qk]], where [n < k], is
+ [[lub p1 q1; ...; lub pk qk]]. *)
val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list
-(* Those two functions recombine one pattern and its arguments:
- For instance:
- (_,_)::p1::p2::rem -> (p1, p2)::rem
- The second one will replace mutable arguments by '_'
+(** Those two functions recombine one pattern and its arguments:
+ For instance:
+ (_,_)::p1::p2::rem -> (p1, p2)::rem
+ The second one will replace mutable arguments by '_'
*)
val set_args : pattern -> pattern list -> pattern list
val set_args_erase_mutable : pattern -> pattern list -> pattern list
val pat_of_constr : pattern -> constructor_description -> pattern
val complete_constrs :
pattern -> constructor_tag list -> constructor_description list
+
+(** [ppat_of_type] builds an untyped or-pattern from its expected type.
+ May raise [Empty] when [type_expr] is an empty variant *)
val ppat_of_type :
Env.t -> type_expr ->
Parsetree.pattern *
(string, label_description) Hashtbl.t
val pressure_variants: Env.t -> pattern list -> unit
-val check_partial_gadt:
+val check_partial:
((string, constructor_description) Hashtbl.t ->
(string, label_description) Hashtbl.t ->
Parsetree.pattern -> pattern option) ->
(* Ambiguous bindings *)
val check_ambiguous_bindings : case list -> unit
-(* The tag used for open polymorphic variant types *)
-val some_other_tag : label
+(* The tag used for open polymorphic variant types with an abstract row *)
+val some_private_tag : label
type_private = Asttypes.Public;
type_manifest = None;
type_variance = [];
- type_newtype_level = None;
+ type_is_newtype = false;
+ type_expansion_scope = None;
type_attributes = [];
type_immediate = false;
type_unboxed = unboxed_false_default_false;
(safe_string, unsafe_string)
let builtin_values =
- List.map (fun id -> Ident.make_global id; (Ident.name id, id))
- [ident_match_failure; ident_out_of_memory; ident_stack_overflow;
- ident_invalid_argument;
- ident_failure; ident_not_found; ident_sys_error; ident_end_of_file;
- ident_division_by_zero; ident_sys_blocked_io;
- ident_assert_failure; ident_undefined_recursive_module ]
+ List.map (fun id -> (Ident.name id, id)) all_predef_exns
(* Start non-predef identifiers at 1000. This way, more predefs can
be defined in this file (above!) without breaking .cmi
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Values as patterns pretty printer *)
+
+open Asttypes
+open Typedtree
+open Types
+open Format
+
+let is_cons = function
+| {cstr_name = "::"} -> true
+| _ -> false
+
+let pretty_const c = match c with
+| Const_int i -> Printf.sprintf "%d" i
+| Const_char c -> Printf.sprintf "%C" c
+| Const_string (s, _) -> Printf.sprintf "%S" s
+| Const_float f -> Printf.sprintf "%s" f
+| Const_int32 i -> Printf.sprintf "%ldl" i
+| Const_int64 i -> Printf.sprintf "%LdL" i
+| Const_nativeint i -> Printf.sprintf "%ndn" i
+
+let rec pretty_val ppf v =
+ match v.pat_extra with
+ (cstr, _loc, _attrs) :: rem ->
+ begin match cstr with
+ | Tpat_unpack ->
+ fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem }
+ | Tpat_constraint _ ->
+ fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem }
+ | Tpat_type _ ->
+ fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
+ | Tpat_open _ ->
+ fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
+ end
+ | [] ->
+ match v.pat_desc with
+ | Tpat_any -> fprintf ppf "_"
+ | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
+ | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
+ | Tpat_tuple vs ->
+ fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
+ | Tpat_construct (_, cstr, []) ->
+ fprintf ppf "%s" cstr.cstr_name
+ | Tpat_construct (_, cstr, [w]) ->
+ fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w
+ | Tpat_construct (_, cstr, vs) ->
+ let name = cstr.cstr_name in
+ begin match (name, vs) with
+ ("::", [v1;v2]) ->
+ fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2
+ | _ ->
+ fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs
+ end
+ | Tpat_variant (l, None, _) ->
+ fprintf ppf "`%s" l
+ | Tpat_variant (l, Some w, _) ->
+ fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
+ | Tpat_record (lvs,_) ->
+ let filtered_lvs = List.filter
+ (function
+ | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
+ | _ -> true) lvs in
+ begin match filtered_lvs with
+ | [] -> fprintf ppf "_"
+ | (_, lbl, _) :: q ->
+ let elision_mark ppf =
+ (* we assume that there is no label repetitions here *)
+ if Array.length lbl.lbl_all > 1 + List.length q then
+ fprintf ppf ";@ _@ "
+ else () in
+ fprintf ppf "@[{%a%t}@]"
+ pretty_lvals filtered_lvs elision_mark
+ end
+ | Tpat_array vs ->
+ fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
+ | Tpat_lazy v ->
+ fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
+ | Tpat_alias (v, x,_) ->
+ fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
+ | Tpat_or (v,w,_) ->
+ fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
+
+and pretty_car ppf v = match v.pat_desc with
+| Tpat_construct (_,cstr, [_ ; _])
+ when is_cons cstr ->
+ fprintf ppf "(%a)" pretty_val v
+| _ -> pretty_val ppf v
+
+and pretty_cdr ppf v = match v.pat_desc with
+| Tpat_construct (_,cstr, [v1 ; v2])
+ when is_cons cstr ->
+ fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
+| _ -> pretty_val ppf v
+
+and pretty_arg ppf v = match v.pat_desc with
+| Tpat_construct (_,_,_::_)
+| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v
+| _ -> pretty_val ppf v
+
+and pretty_or ppf v = match v.pat_desc with
+| Tpat_or (v,w,_) ->
+ fprintf ppf "%a|@,%a" pretty_or v pretty_or w
+| _ -> pretty_val ppf v
+
+and pretty_vals sep ppf = function
+ | [] -> ()
+ | [v] -> pretty_val ppf v
+ | v::vs ->
+ fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs
+
+and pretty_lvals ppf = function
+ | [] -> ()
+ | [_,lbl,v] ->
+ fprintf ppf "%s=%a" lbl.lbl_name pretty_val v
+ | (_, lbl,v)::rest ->
+ fprintf ppf "%s=%a;@ %a"
+ lbl.lbl_name pretty_val v pretty_lvals rest
+
+let top_pretty ppf v =
+ fprintf ppf "@[%a@]@?" pretty_val v
+
+
+let pretty_pat p =
+ top_pretty Format.str_formatter p ;
+ prerr_string (Format.flush_str_formatter ())
+
+type matrix = pattern list list
+
+let pretty_line fmt =
+ List.iter (fun p ->
+ Format.fprintf fmt " <";
+ top_pretty fmt p;
+ Format.fprintf fmt ">";
+ )
+
+let pretty_matrix fmt (pss : matrix) =
+ Format.fprintf fmt "begin matrix\n" ;
+ List.iter (fun ps ->
+ pretty_line fmt ps ;
+ Format.fprintf fmt "\n"
+ ) pss;
+ Format.fprintf fmt "end matrix\n%!"
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+
+
+val pretty_const : Asttypes.constant -> string
+val top_pretty : Format.formatter -> Typedtree.pattern -> unit
+val pretty_pat : Typedtree.pattern -> unit
+val pretty_line : Format.formatter -> Typedtree.pattern list -> unit
+val pretty_matrix : Format.formatter -> Typedtree.pattern list list -> unit
(* Print a path *)
-let ident_pervasives = Ident.create_persistent "Pervasives"
+let ident_stdlib = Ident.create_persistent "Stdlib"
let printing_env = ref Env.empty
let non_shadowed_pervasive = function
- | Pdot(Pident id, s, _pos) as path ->
- Ident.same id ident_pervasives &&
+ | Pdot(Pident id, s, _) as path ->
+ Ident.same id ident_stdlib &&
(try Path.same path (Env.lookup_type (Lident s) !printing_env)
with Not_found -> true)
+ | Pdot(Pdot (Pident id, "Pervasives", _), s, _) as path ->
+ Ident.same id ident_stdlib &&
+ (* Make sure Stdlib.<s> is the same as Stdlib.Pervasives.<s> *)
+ (try
+ let td =
+ Env.find_type (Env.lookup_type (Lident s) !printing_env)
+ !printing_env
+ in
+ match td.type_private, td.type_manifest with
+ | Private, _ | _, None -> false
+ | Public, Some te ->
+ match (Btype.repr te).desc with
+ | Tconstr (path', _, _) -> Path.same path path'
+ | _ -> false
+ with Not_found -> true)
| _ -> false
+let find_double_underscore s =
+ let len = String.length s in
+ let rec loop i =
+ if i + 1 >= len then
+ None
+ else if s.[i] = '_' && s.[i + 1] = '_' then
+ Some i
+ else
+ loop (i + 1)
+ in
+ loop 0
+
+let rec module_path_is_an_alias_of env path ~alias_of =
+ match Env.find_module path env with
+ | { md_type = Mty_alias (_, path'); _ } ->
+ Path.same path' alias_of ||
+ module_path_is_an_alias_of env path' ~alias_of
+ | _ -> false
+ | exception Not_found -> false
+
+(* Simple heuristic to print Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias
+ for Foo__bar. This pattern is used by the stdlib. *)
+let rec rewrite_double_underscore_paths env p =
+ match p with
+ | Pdot (p, s, n) ->
+ Pdot (rewrite_double_underscore_paths env p, s, n)
+ | Papply (a, b) ->
+ Papply (rewrite_double_underscore_paths env a,
+ rewrite_double_underscore_paths env b)
+ | Pident id ->
+ let name = Ident.name id in
+ match find_double_underscore name with
+ | None -> p
+ | Some i ->
+ let better_lid =
+ Ldot
+ (Lident (String.sub name 0 i),
+ String.capitalize_ascii
+ (String.sub name (i + 2) (String.length name - i - 2)))
+ in
+ match Env.lookup_module ~load:true better_lid env with
+ | exception Not_found -> p
+ | p' ->
+ if module_path_is_an_alias_of env p' ~alias_of:p then
+ p'
+ else
+ p
+
+let rewrite_double_underscore_paths env p =
+ if env == Env.empty then
+ p
+ else
+ rewrite_double_underscore_paths env p
+
let rec tree_of_path = function
| Pident id ->
Oide_ident (ident_name id)
- | Pdot(_, s, _pos) as path when non_shadowed_pervasive path ->
+ | Pdot(_, s, _pos) as path
+ when non_shadowed_pervasive path ->
Oide_ident s
| Pdot(p, s, _pos) ->
Oide_dot (tree_of_path p, s)
| Papply(p1, p2) ->
- Oide_apply (tree_of_path p1, tree_of_path p2)
+ Oide_apply (tree_of_path p1,
+ tree_of_path p2)
let rec path ppf = function
| Pident id ->
ident ppf id
- | Pdot(_, s, _pos) as path when non_shadowed_pervasive path ->
+ | Pdot(_, s, _pos) as path
+ when non_shadowed_pervasive path ->
pp_print_string ppf s
| Pdot(p, s, _pos) ->
path ppf p;
| Papply(p1, p2) ->
fprintf ppf "%a(%a)" path p1 path p2
+let tree_of_path p =
+ tree_of_path (rewrite_double_underscore_paths !printing_env p)
+let path ppf p =
+ path ppf (rewrite_double_underscore_paths !printing_env p)
+
let rec string_of_out_ident = function
| Oide_ident s -> s
| Oide_dot (id, s) -> String.concat "." [string_of_out_ident id; s]
if s <> "" && s.[0] = '_' then
10
else
- try
- for i = 0 to String.length s - 2 do
- if s.[i] = '_' && s.[i + 1] = '_' then
- raise Exit
- done;
- 1
- with Exit -> 10
+ match find_double_underscore s with
+ | None -> 1
+ | Some _ -> 10
let rec path_size = function
Pident id ->
let set_printing_env env =
printing_env := env;
- if !Clflags.real_paths
- || !printing_env == Env.empty || same_printing_env env then () else
- begin
+ if !Clflags.real_paths ||
+ !printing_env == Env.empty ||
+ same_printing_env env then
+ ()
+ else begin
(* printf "Reset printing_map@."; *)
printing_old := env;
printing_pers := Env.used_persistent ();
set_printing_env env;
try_finally f (fun () -> set_printing_env Env.empty)
-let wrap_printing_env env f =
- Env.without_cmis (wrap_printing_env env) f
+let wrap_printing_env ~error env f =
+ if error then Env.without_cmis (wrap_printing_env env) f
+ else wrap_printing_env env f
let is_unambiguous path env =
let l = Env.find_shadowed_types path env in
get_best_path r
let best_type_path p =
- if !Clflags.real_paths || !printing_env == Env.empty
+ if !printing_env == Env.empty
+ then (p, Id)
+ else if !Clflags.real_paths
then (p, Id)
else
let (p', s) = normalize_type_path !printing_env p in
and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty
+let type_expansion ppf ty1 ty2 =
+ let tree1 = tree_of_typexp false ty1 in
+ let tree2 = tree_of_typexp false ty2 in
+ let pp = !Oprint.out_type in
+ if tree1 = tree2 then
+ pp ppf tree1
+ else
+ fprintf ppf "@[<2>%a@ =@ %a@]" pp tree1 pp tree2
+
(* Maxence *)
let type_scheme_max ?(b_reset_names=true) ppf ty =
if b_reset_names then reset_names () ;
let dummy =
{ type_params = []; type_arity = 0; type_kind = Type_abstract;
type_private = Public; type_manifest = None; type_variance = [];
- type_newtype_level = None; type_loc = Location.none;
+ type_is_newtype = false; type_expansion_scope = None;
+ type_loc = Location.none;
type_attributes = [];
type_immediate = false;
type_unboxed = unboxed_false_default_false;
then begin add_delayed (proxy t); type_expr ppf t end
else
let t' = if proxy t == proxy t' then unalias t' else t' in
- fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t'
+ type_expansion ppf t t'
let type_path_expansion tp ppf tp' =
if Path.same tp tp' then path ppf tp else
fprintf ppf "`%s" t;
List.iter (fun (t, _) -> fprintf ppf ",@ `%s" t) fields
-let has_explanation t3 t4 =
- match t3.desc, t4.desc with
- Tfield _, (Tnil|Tconstr _) | (Tnil|Tconstr _), Tfield _
- | Tnil, Tconstr _ | Tconstr _, Tnil
- | _, Tvar _ | Tvar _, _
- | Tvariant _, Tvariant _ -> true
- | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) -> l = l'
+let is_unit env ty =
+ match (Ctype.expand_head env ty).desc with
+ | Tconstr (p, _, _) -> Path.same p Predef.path_unit
| _ -> false
-let rec mismatch = function
- (_, t) :: (_, t') :: rem ->
- begin match mismatch rem with
- Some _ as m -> m
- | None ->
- if has_explanation t t' then Some(t,t') else None
- end
- | [] -> None
- | _ -> assert false
+let unifiable env ty1 ty2 =
+ let snap = Btype.snapshot () in
+ let res =
+ try Ctype.unify env ty1 ty2; true
+ with Unify _ -> false
+ in
+ Btype.backtrack snap;
+ res
-let explanation unif t3 t4 ppf =
+let explanation env unif t3 t4 : (Format.formatter -> unit) option =
match t3.desc, t4.desc with
+ | Tarrow (_, ty1, ty2, _), _
+ when is_unit env ty1 && unifiable env ty2 t4 ->
+ Some (fun ppf ->
+ fprintf ppf
+ "@,@[Hint: Did you forget to provide `()' as argument?@]")
+ | _, Tarrow (_, ty1, ty2, _)
+ when is_unit env ty1 && unifiable env t3 ty2 ->
+ Some (fun ppf ->
+ fprintf ppf
+ "@,@[Hint: Did you forget to wrap the expression using `fun () ->'?@]")
| Ttuple [], Tvar _ | Tvar _, Ttuple [] ->
- fprintf ppf "@,Self type cannot escape its class"
+ Some (fun ppf ->
+ fprintf ppf "@,Self type cannot escape its class")
| Tconstr (p, _, _), Tvar _
when unif && t4.level < Path.binding_time p ->
- fprintf ppf
- "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
- path p
+ Some (fun ppf ->
+ fprintf ppf
+ "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
+ path p)
| Tvar _, Tconstr (p, _, _)
when unif && t3.level < Path.binding_time p ->
- fprintf ppf
- "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
- path p
+ Some (fun ppf ->
+ fprintf ppf
+ "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
+ path p)
| Tvar _, Tunivar _ | Tunivar _, Tvar _ ->
- fprintf ppf "@,The universal variable %a would escape its scope"
- type_expr (if is_Tunivar t3 then t3 else t4)
+ Some (fun ppf ->
+ fprintf ppf "@,The universal variable %a would escape its scope"
+ type_expr (if is_Tunivar t3 then t3 else t4))
| Tvar _, _ | _, Tvar _ ->
- let t, t' = if is_Tvar t3 then (t3, t4) else (t4, t3) in
- if occur_in Env.empty t t' then
- fprintf ppf "@,@[<hov>The type variable %a occurs inside@ %a@]"
- type_expr t type_expr t'
- else
- fprintf ppf "@,@[<hov>This instance of %a is ambiguous:@ %s@]"
- type_expr t'
- "it would escape the scope of its equation"
+ Some (fun ppf ->
+ let t, t' = if is_Tvar t3 then (t3, t4) else (t4, t3) in
+ if occur_in Env.empty t t' then
+ fprintf ppf "@,@[<hov>The type variable %a occurs inside@ %a@]"
+ type_expr t type_expr t'
+ else
+ fprintf ppf "@,@[<hov>This instance of %a is ambiguous:@ %s@]"
+ type_expr t'
+ "it would escape the scope of its equation")
| Tfield (lab, _, _, _), _ when lab = dummy_method ->
- fprintf ppf
- "@,Self type cannot be unified with a closed object type"
+ Some (fun ppf ->
+ fprintf ppf
+ "@,Self type cannot be unified with a closed object type")
| _, Tfield (lab, _, _, _) when lab = dummy_method ->
- fprintf ppf
- "@,Self type cannot be unified with a closed object type"
+ Some (fun ppf ->
+ fprintf ppf
+ "@,Self type cannot be unified with a closed object type")
| Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) when l = l' ->
- fprintf ppf "@,Types for method %s are incompatible" l
+ Some (fun ppf ->
+ fprintf ppf "@,Types for method %s are incompatible" l)
| (Tnil|Tconstr _), Tfield (l, _, _, _) ->
- fprintf ppf
- "@,@[The first object type has no method %s@]" l
+ Some (fun ppf ->
+ fprintf ppf
+ "@,@[The first object type has no method %s@]" l)
| Tfield (l, _, _, _), (Tnil|Tconstr _) ->
- fprintf ppf
- "@,@[The second object type has no method %s@]" l
+ Some (fun ppf ->
+ fprintf ppf
+ "@,@[The second object type has no method %s@]" l)
| Tnil, Tconstr _ | Tconstr _, Tnil ->
- fprintf ppf
- "@,@[The %s object type has an abstract row, it cannot be closed@]"
- (if t4.desc = Tnil then "first" else "second")
+ Some (fun ppf ->
+ fprintf ppf
+ "@,@[The %s object type has an abstract row, it cannot be closed@]"
+ (if t4.desc = Tnil then "first" else "second"))
| Tvariant row1, Tvariant row2 ->
- let row1 = row_repr row1 and row2 = row_repr row2 in
- begin match
- row1.row_fields, row1.row_closed, row2.row_fields, row2.row_closed with
- | [], true, [], true ->
- fprintf ppf "@,These two variant types have no intersection"
- | [], true, (_::_ as fields), _ ->
- fprintf ppf
- "@,@[The first variant type does not allow tag(s)@ @[<hov>%a@]@]"
- print_tags fields
- | (_::_ as fields), _, [], true ->
- fprintf ppf
- "@,@[The second variant type does not allow tag(s)@ @[<hov>%a@]@]"
- print_tags fields
- | [l1,_], true, [l2,_], true when l1 = l2 ->
- fprintf ppf "@,Types for tag `%s are incompatible" l1
- | _ -> ()
+ Some (fun ppf ->
+ let row1 = row_repr row1 and row2 = row_repr row2 in
+ begin match
+ row1.row_fields, row1.row_closed, row2.row_fields, row2.row_closed with
+ | [], true, [], true ->
+ fprintf ppf "@,These two variant types have no intersection"
+ | [], true, (_::_ as fields), _ ->
+ fprintf ppf
+ "@,@[The first variant type does not allow tag(s)@ @[<hov>%a@]@]"
+ print_tags fields
+ | (_::_ as fields), _, [], true ->
+ fprintf ppf
+ "@,@[The second variant type does not allow tag(s)@ @[<hov>%a@]@]"
+ print_tags fields
+ | [l1,_], true, [l2,_], true when l1 = l2 ->
+ fprintf ppf "@,Types for tag `%s are incompatible" l1
+ | _ -> ()
+ end)
+ | _ ->
+ None
+
+let rec mismatch env unif = function
+ (_, t) :: (_, t') :: rem ->
+ begin match mismatch env unif rem with
+ Some _ as m -> m
+ | None -> explanation env unif t t'
end
- | _ -> ()
+ | [] -> None
+ | _ -> assert false
+let explain mis ppf =
+ match mis with
+ | None -> ()
+ | Some explain -> explain ppf
let warn_on_missing_def env ppf t =
match t.desc with
end
| _ -> ()
-let explanation unif mis ppf =
- match mis with
- None -> ()
- | Some (t3, t4) -> explanation unif t3 t4 ppf
-
let ident_same_name id1 id2 =
if Ident.equal id1 id2 && not (Ident.same id1 id2) then begin
add_unique id1; add_unique id2
type_same_name t1 t2; type_same_name t1' t2'; trace_same_names rem
| _ -> ()
-let unification_error env unif tr txt1 ppf txt2 =
+let unification_error env unif tr txt1 ppf txt2 ty_expect_explanation =
reset ();
trace_same_names tr;
let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
- let mis = mismatch tr in
+ let mis = mismatch env unif tr in
match tr with
| [] | _ :: [] -> assert false
| t1 :: t2 :: tr ->
"@[<v>\
@[%t@;<1 2>%a@ \
%t@;<1 2>%a\
+ %t\
@]%a%t\
@]"
txt1 (type_expansion t1) t1'
txt2 (type_expansion t2) t2'
+ ty_expect_explanation
(trace false "is not compatible with type") tr
- (explanation unif mis);
+ (explain mis);
if env <> Env.empty
then begin
warn_on_missing_def env ppf t1;
print_labels := true;
raise exn
-let report_unification_error ppf env ?(unif=true)
- tr txt1 txt2 =
- wrap_printing_env env (fun () -> unification_error env unif tr txt1 ppf txt2)
+let report_unification_error ppf env ?(unif=true) tr
+ ?(type_expected_explanation = fun _ -> ())
+ txt1 txt2 =
+ wrap_printing_env env (fun () -> unification_error env unif tr txt1 ppf txt2
+ type_expected_explanation)
+ ~error:true
;;
let trace fst keep_last txt ppf tr =
raise exn
let report_subtyping_error ppf env tr1 txt1 tr2 =
- wrap_printing_env env (fun () ->
+ wrap_printing_env ~error:true env (fun () ->
reset ();
let tr1 = List.map prepare_expansion tr1
and tr2 = List.map prepare_expansion tr2 in
fprintf ppf "@[<v>%a" (trace true (tr2 = []) txt1) tr1;
if tr2 = [] then fprintf ppf "@]" else
- let mis = mismatch tr2 in
+ let mis = mismatch env true tr2 in
fprintf ppf "%a%t@]"
(trace false (mis = None) "is not compatible with type") tr2
- (explanation true mis))
+ (explain mis))
let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 =
- wrap_printing_env env (fun () ->
+ wrap_printing_env ~error:true env (fun () ->
reset ();
List.iter
(fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp')
val raw_type_expr: formatter -> type_expr -> unit
val string_of_label: Asttypes.arg_label -> string
-val wrap_printing_env: Env.t -> (unit -> 'a) -> 'a
+val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a
(* Call the function using the environment for type path shortening *)
(* This affects all the printing functions below *)
+ (* Also, if [~error:true], then disable the loading of cmis *)
val reset: unit -> unit
val mark_loops: type_expr -> unit
val trace:
bool -> bool-> string -> formatter -> (type_expr * type_expr) list -> unit
val report_unification_error:
- formatter -> Env.t -> ?unif:bool -> (type_expr * type_expr) list ->
+ formatter -> Env.t -> ?unif:bool ->
+ (type_expr * type_expr) list ->
+ ?type_expected_explanation:(formatter -> unit) ->
(formatter -> unit) -> (formatter -> unit) ->
unit
val report_subtyping_error:
(* for toploop *)
val print_items: (Env.t -> signature_item -> 'a option) ->
Env.t -> signature_item list -> (out_sig_item * 'a option) list
+
+(* Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias for
+ Foo__bar. This pattern is used by the stdlib. *)
+val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t
+
printtyp_reset_maybe loc;
Printtyp.mark_loops typ;
Format.pp_print_string Format.str_formatter " ";
- Printtyp.wrap_printing_env env
+ Printtyp.wrap_printing_env ~error:false env
(fun () -> Printtyp.type_sch Format.str_formatter typ);
Format.pp_print_newline Format.str_formatter ();
let s = Format.flush_str_formatter () in
let newpersty desc =
decr new_id;
- { desc = desc; level = generic_level; id = !new_id }
+ { desc = desc; level = generic_level; scope = None; id = !new_id }
(* ensure that all occurrences of 'Tvar None' are physically shared *)
let tvar_none = Tvar None
end;
type_private = decl.type_private;
type_variance = decl.type_variance;
- type_newtype_level = None;
+ type_is_newtype = false;
+ type_expansion_scope = None;
type_loc = loc s decl.type_loc;
type_attributes = attrs s decl.type_attributes;
type_immediate = decl.type_immediate;
| Mutability_mismatch of string * mutable_flag
| No_overriding of string * string
| Duplicate of string * string
+ | Closing_self_type of type_expr
exception Error of Location.t * Env.t * error
exception Error_forward of Location.error
(* Enter an instance variable in the environment *)
let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
- let instance = Ctype.instance val_env in
let (id, virt) =
try
let (id, mut', virt', ty') = Vars.find lab !vars in
if mut' <> mut then
raise (Error(loc, val_env, Mutability_mismatch(lab, mut)));
- Ctype.unify val_env (instance ty) (instance ty');
+ Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty');
(if not inh then Some id else None),
(if virt' = Concrete then virt' else virt)
with
(fun () ->
(* Read the generalized type *)
let (_, ty) = Meths.find lab.txt !meths in
- let meth_type =
- Btype.newgenty (Tarrow(Nolabel, self_type, ty, Cok)) in
+ let meth_type = mk_expected (
+ Btype.newgenty (Tarrow(Nolabel, self_type, ty, Cok))
+ ) in
Ctype.raise_nongen_level ();
vars := vars_local;
let texp = type_expect met_env meth_expr meth_type in
let field =
lazy begin
Ctype.raise_nongen_level ();
- let meth_type =
+ let meth_type = mk_expected (
Ctype.newty
(Tarrow (Nolabel, self_type,
- Ctype.instance_def Predef.type_unit, Cok)) in
+ Ctype.instance_def Predef.type_unit, Cok))
+ ) in
vars := vars_local;
let texp = type_expect met_env expr meth_type in
Ctype.end_def ();
| Pcf_extension ext ->
raise (Error_forward (Builtin_attributes.error_of_extension ext))
+(* N.B. the self type of a final object type doesn't contain a dummy method in
+ the beginning.
+ We only explicitely add a dummy method to class definitions (and class (type)
+ declarations)), which are later removed (made absent) by [final_decl].
+
+ If we ever find a dummy method in a final object self type, it means that
+ somehow we've unified the self type of the object with the self type of a not
+ yet finished class.
+ When this happens, we cannot close the object type and must error. *)
and class_structure cl_num final val_env met_env loc
{ pcstr_self = spat; pcstr_fields = str } =
(* Environment for substructures *)
(* Location of self. Used for locations of self arguments *)
let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in
- (* Self type, with a dummy method preventing it from being closed/escaped. *)
- let self_type = Ctype.newvar () in
- Ctype.unify val_env
- (Ctype.filter_method val_env dummy_method Private self_type)
- (Ctype.newty (Ttuple []));
+ let self_type = Ctype.newobj (Ctype.newvar ()) in
+
+ (* Adding a dummy method to the self type prevents it from being closed /
+ escaping.
+ That isn't needed for objects though. *)
+ if not final then
+ Ctype.unify val_env
+ (Ctype.filter_method val_env dummy_method Private self_type)
+ (Ctype.newty (Ttuple []));
(* Private self is used for private method calls *)
let private_self = if final then Ctype.newvar () else self_type in
if final then begin
(* Unify private_self and a copy of self_type. self_type will not
be modified after this point *)
- Ctype.close_object self_type;
+ begin try Ctype.close_object self_type
+ with Ctype.Unify [] ->
+ raise(Error(loc, val_env, Closing_self_type self_type))
+ end;
let mets = virtual_methods {sign with csig_self = self_type} in
let vals =
Vars.fold
let self_methods =
List.fold_right
(fun (lab,kind,ty) rem ->
- if lab = dummy_method then
- (* allow public self and private self to be unified *)
- match Btype.field_kind_repr kind with
- Fvar r -> Btype.set_kind r Fabsent; rem
- | _ -> rem
- else
- Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
+ Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
methods (Ctype.newty Tnil) in
begin try
Ctype.unify val_env private_self
(* Generalize the spine of methods accessed through self *)
Meths.iter (fun _ (_,ty) -> Ctype.generalize_spine ty) ms;
meths :=
- Meths.map (fun (id,ty) -> (id, Ctype.generic_instance val_env ty)) ms;
+ Meths.map (fun (id,ty) -> (id, Ctype.generic_instance ty)) ms;
(* But keep levels correct on the type of self *)
Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms
end;
{exp_desc =
Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd);
exp_loc = Location.none; exp_extra = [];
- exp_type = Ctype.instance val_env' vd.val_type;
+ exp_type = Ctype.instance vd.val_type;
exp_attributes = []; (* check *)
exp_env = val_env'})
end
{exp_desc =
Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd);
exp_loc = Location.none; exp_extra = [];
- exp_type = Ctype.instance val_env vd.val_type;
+ exp_type = Ctype.instance vd.val_type;
exp_attributes = [];
exp_env = val_env;
}
type_private = Public;
type_manifest = Some ty;
type_variance = Misc.replicate_list Variance.full arity;
- type_newtype_level = None;
+ type_is_newtype = false;
+ type_expansion_scope = None;
type_loc = loc;
type_attributes = []; (* or keep attrs from the class decl? *)
type_immediate = false;
begin
let ty = Ctype.self_type obj_type in
Ctype.hide_private_methods ty;
- Ctype.close_object ty;
+ begin try Ctype.close_object ty
+ with Ctype.Unify [] -> raise(Error(cl.pci_loc, env, Closing_self_type ty))
+ end;
begin try
List.iter2 (Ctype.unify env) obj_params obj_params'
with Ctype.Unify _ ->
begin try
Ctype.unify env
(constructor_type constr obj_type)
- (Ctype.instance env constr_type)
+ (Ctype.instance constr_type)
with Ctype.Unify trace ->
raise(Error(cl.pci_loc, env,
Constructor_type_mismatch (cl.pci_name.txt, trace)))
cty_new =
begin match cl.pci_virt with
| Virtual -> None
- | Concrete -> Some (Ctype.instance env constr_type)
+ | Concrete -> Some (Ctype.instance constr_type)
end;
cty_loc = cl.pci_loc;
cty_attributes = cl.pci_attributes;
type_private = Public;
type_manifest = Some obj_ty;
type_variance = List.map (fun _ -> Variance.full) obj_params;
- type_newtype_level = None;
+ type_is_newtype = false;
+ type_expansion_scope = None;
type_loc = cl.pci_loc;
type_attributes = []; (* or keep attrs from cl? *)
type_immediate = false;
type_private = Public;
type_manifest = Some cl_ty;
type_variance = List.map (fun _ -> Variance.full) cl_params;
- type_newtype_level = None;
+ type_is_newtype = false;
+ type_expansion_scope = None;
type_loc = cl.pci_loc;
type_attributes = []; (* or keep attrs from cl? *)
type_immediate = false;
raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace)))
end;
+ (* make the dummy method disappear *)
+ begin
+ let self_type = Ctype.self_type clty.cty_type in
+ let methods, _ =
+ Ctype.flatten_fields
+ (Ctype.object_fields (Ctype.expand_head env self_type))
+ in
+ List.iter (fun (lab,kind,_) ->
+ if lab = dummy_method then
+ match Btype.field_kind_repr kind with
+ Fvar r -> Btype.set_kind r Fabsent
+ | _ -> ()
+ ) methods
+ end;
+
List.iter Ctype.generalize clty.cty_params;
generalize_class_type true clty.cty_type;
Misc.may Ctype.generalize clty.cty_new;
begin try
let decl = Env.find_class p env in
let _, body = Ctype.find_cltype_for_path env decl.cty_path in
- Ctype.unify env ty (Ctype.instance env body)
+ Ctype.unify env ty (Ctype.instance body)
with
Not_found -> ()
| _exn -> assert false
| Duplicate (kind, name) ->
fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]"
kind name
+ | Closing_self_type self ->
+ fprintf ppf
+ "@[Cannot close type of object literal:@ %a@,\
+ it has been unified with the self type of a class that is not yet@ \
+ completely defined.@]"
+ Printtyp.type_scheme self
let report_error env ppf err =
- Printtyp.wrap_printing_env env (fun () -> report_error env ppf err)
+ Printtyp.wrap_printing_env ~error:true
+ env (fun () -> report_error env ppf err)
let () =
Location.register_error_of_exn
| Mutability_mismatch of string * mutable_flag
| No_overriding of string * string
| Duplicate of string * string
+ | Closing_self_type of type_expr
exception Error of Location.t * Env.t * error
exception Error_forward of Location.error
open Btype
open Ctype
+type type_forcing_context =
+ | If_conditional
+ | If_no_else_branch
+ | While_loop_conditional
+ | While_loop_body
+ | For_loop_start_index
+ | For_loop_stop_index
+ | For_loop_body
+ | Assert_condition
+ | Sequence_left_hand_side
+
+type type_expected = {
+ ty: type_expr;
+ explanation: type_forcing_context option;
+}
+
type error =
Polymorphic_label of Longident.t
| Constructor_arity_mismatch of Longident.t * int * int
| Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list
| Multiply_bound_variable of string
| Orpat_vars of Ident.t * Ident.t list
- | Expr_type_clash of (type_expr * type_expr) list
+ | Expr_type_clash of (type_expr * type_expr) list * type_forcing_context option
| Apply_non_function of type_expr
| Apply_wrong_label of arg_label * type_expr
| Label_multiply_defined of string
| Label_missing of Ident.t list
| Label_not_mutable of Longident.t
- | Wrong_name of string * type_expr * string * Path.t * string * string list
+ | Wrong_name of string * type_expected * string * Path.t * string * string list
| Name_type_mismatch of
string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
| Invalid_format of string
| Value_multiply_overridden of string
| Coercion_failure of
type_expr * type_expr * (type_expr * type_expr) list * bool
- | Too_many_arguments of bool * type_expr
- | Abstract_wrong_label of arg_label * type_expr
+ | Too_many_arguments of bool * type_expr * type_forcing_context option
+ | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option
| Scoping_let_module of string * type_expr
| Masked_instance_variable of Longident.t
| Not_a_variant_type of Longident.t
| Not_a_packed_module of type_expr
| Recursive_local_constraint of (type_expr * type_expr) list
| Unexpected_existential
- | Unqualified_gadt_pattern of Path.t * string
| Invalid_interval
| Invalid_for_loop_index
| No_value_clauses
| Illegal_letrec_pat
| Illegal_letrec_expr
| Illegal_class_expr
+ | Empty_pattern
exception Error of Location.t * Env.t * error
exception Error_forward of Location.error
| Rejected
+let mk_expected ?explanation ty = { ty; explanation; }
+
let case lhs rhs =
{c_lhs = lhs; c_guard = None; c_rhs = rhs}
unify env ty expected_ty
with
Unify trace ->
- raise(Error(loc, env, Expr_type_clash(trace)))
+ raise(Error(loc, env, Expr_type_clash(trace, None)))
| Tags(l1,l2) ->
raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
(* level at which to create the local type declarations *)
-let newtype_level = ref None
-let get_newtype_level () =
- match !newtype_level with
+let gadt_equations_level = ref None
+let get_gadt_equations_level () =
+ match !gadt_equations_level with
Some y -> y
| None -> assert false
let unify_pat_types_gadt loc env ty ty' =
- let newtype_level =
- match !newtype_level with
- | None -> assert false
- | Some x -> x
- in
- try
- unify_gadt ~newtype_level env ty ty'
+ try unify_gadt ~equations_level:(get_gadt_equations_level ()) env ty ty'
with
- Unify trace ->
+ | Unify trace ->
raise(Error(loc, !env, Pattern_type_clash(trace)))
| Tags(l1,l2) ->
raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2)))
Some {type_manifest = Some ty} ->
begin match repr ty with
{desc=Tconstr(p,_,_)} -> expand_path env p
- | _ -> p
- (* PR#6394: recursive module may introduce incoherent manifest *)
+ | _ -> assert false
end
| _ ->
let p' = Env.normalize_path None env p in
let lookup_from_type env tpath lid =
let descrs = get_descrs (Env.find_type_descrs tpath env) in
- Env.mark_type_used env (Path.last tpath) (Env.find_type tpath env);
+ Env.mark_type_used (Path.last tpath) (Env.find_type tpath env);
match lid.txt with
Longident.Lident s -> begin
try
with Not_found ->
let names = List.map get_name descrs in
raise (Error (lid.loc, env,
- Wrong_name ("", newvar (), type_kind, tpath, s, names)))
+ Wrong_name ("", mk_expected (newvar ()),
+ type_kind, tpath, s, names)))
end
| _ -> raise Not_found
in
List.find check_type lbls
- let disambiguate ?(warn=Location.prerr_warning) ?(check_lk=fun _ _ -> ())
- ?scope lid env opath lbls =
+ let disambiguate ?(warn=Location.prerr_warning) ?scope lid env opath lbls =
let scope = match scope with None -> lbls | Some l -> l in
let lbl = match opath with
None ->
lbl
with Not_found -> try
let lbl = lookup_from_type env tpath lid in
- check_lk tpath lbl;
if in_env lbl then
begin
let s = Printtyp.string_of_path tpath in
pat_env = !env }
in
if explode > 0 then
- let (sp, constrs, labels) = Parmatch.ppat_of_type !env expected_ty in
+ let (sp, constrs, labels) =
+ try
+ Parmatch.ppat_of_type !env expected_ty
+ with Parmatch.Empty -> raise (Error (loc, !env, Empty_pattern))
+ in
if sp.ppat_desc = Parsetree.Ppat_any then k' Tpat_any else
if mode = Inside_or then raise Need_backtrack else
let explode =
[Hashtbl.find constrs s, (fun () -> ())]
| _ -> Typetexp.find_all_constructors !env lid.loc lid.txt
in
- let check_lk tpath constr =
- if constr.cstr_generalized then
- raise (Error (lid.loc, !env,
- Unqualified_gadt_pattern (tpath, constr.cstr_name)))
- in
let constr =
- wrap_disambiguate "This variant pattern is expected to have" expected_ty
- (Constructor.disambiguate lid !env opath ~check_lk) candidates
+ wrap_disambiguate "This variant pattern is expected to have"
+ (mk_expected expected_ty)
+ (Constructor.disambiguate lid !env opath) candidates
in
if constr.cstr_generalized && constrs <> None && mode = Inside_or
then raise Need_backtrack;
raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt,
constr.cstr_arity, List.length sargs)));
let (ty_args, ty_res) =
- instance_constructor ~in_pattern:(env, get_newtype_level ()) constr
+ instance_constructor ~in_pattern:(env, get_gadt_equations_level ())
+ constr
in
(* PR#7214: do not use gadt unification for toplevel lets *)
if not constr.cstr_generalized || mode = Inside_or || no_existentials
row_more = newvar ();
row_fixed = false;
row_name = None } in
- (* PR#7404: allow some_other_tag blindly, as it would not unify with
+ (* PR#7404: allow some_private_tag blindly, as it would not unify with
the abstract row variable *)
- if l = Parmatch.some_other_tag then assert (constrs <> None)
+ if l = Parmatch.some_private_tag then assert (constrs <> None)
else unify_pat_types loc !env (newty (Tvariant row)) expected_ty;
let k arg =
rp k {
in
if constrs = None then
k (wrap_disambiguate "This record pattern is expected to have"
- expected_ty
+ (mk_expected expected_ty)
(type_label_a_list ?labels loc false !env type_label_pat opath
lid_sp_list)
(k' (fun x -> x)))
let ty_elt = newvar() in
unify_pat_types
loc !env (instance_def (Predef.type_array ty_elt)) expected_ty;
- let spl_ann = List.map (fun p -> (p,newvar())) spl in
- map_fold_cont (fun (p,_) -> type_pat p ty_elt) spl_ann (fun pl ->
+ map_fold_cont (fun p -> type_pat p ty_elt) spl (fun pl ->
rp k {
pat_desc = Tpat_array pl;
pat_loc = loc; pat_extra=[];
if separate then begin
end_def();
generalize_structure ty;
- instance !env ty, instance !env ty
+ instance ty, instance ty
end else ty, ty
in
unify_pat_types loc !env ty expected_ty;
let type_pat ?(allow_existentials=false) ?constrs ?labels ?(mode=Normal)
?(explode=0) ?(lev=get_current_level()) env sp expected_ty =
- newtype_level := Some lev;
+ gadt_equations_level := Some lev;
try
let r =
type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels
~mode ~explode ~env sp expected_ty (fun x -> x) in
iter_pattern (fun p -> p.pat_env <- !env) r;
- newtype_level := None;
+ gadt_equations_level := None;
r
with e ->
- newtype_level := None;
+ gadt_equations_level := None;
raise e
let check_partial ?(lev=get_current_level ()) env expected_ty loc cases =
let explode = match cases with [_] -> 5 | _ -> 0 in
- Parmatch.check_partial_gadt
+ Parmatch.check_partial
(partial_pred ~lev ~explode env expected_ty) loc cases
let check_unused ?(lev=get_current_level ()) env expected_ty cases =
is_nonexpansive exp
| Texp_apply (
{ exp_desc = Texp_ident (_, _, {val_kind =
- Val_prim {Primitive.prim_name = "%raise"}}) },
+ Val_prim {Primitive.prim_name =
+ ("%raise" | "%reraise" | "%raise_notrace")}}) },
[Nolabel, Some e]) ->
is_nonexpansive e
| _ -> false
val empty : t
(** No variables are accessed in an expression; it might be a
constant or a global identifier *)
-
+
val unguarded : t -> Ident.t list
(** The list of identifiers that are used in an unguarded context *)
x y
let single id access = M.add id access M.empty
-
+
let empty = M.empty
let list_matching p t =
let r = ref [] in
M.iter (fun id v -> if p v then r := id :: !r) t;
!r
-
+
let unguarded =
list_matching (function Unguarded | Dereferenced -> true | _ -> false)
let empty = Ident.empty
let join x y =
- let r =
+ let r =
Ident.fold_all
(fun id v tbl ->
let v' = try Ident.find_same id tbl with Not_found -> Use.empty in
if Path.same p Predef.path_int || Path.same p Predef.path_char then
`Pintarray
else if Path.same p Predef.path_float then
- `Pfloatarray
+ if Config.flat_float_array then `Pfloatarray else `Paddrarray
else if Path.same p Predef.path_string
|| Path.same p Predef.path_array
|| Path.same p Predef.path_nativeint
let has_concrete_element_type : Typedtree.expression -> bool =
fun e -> array_kind e <> `Pgenarray
+ (* See the note on abstracted arguments in the documentation for
+ Typedtree.Texp_apply *)
+ let is_abstracted_arg : arg_label * expression option -> bool = function
+ | (_, None) -> true
+ | (_, Some _) -> false
+
type sd = Static | Dynamic
- let rec classify_expression : Typedtree.expression -> sd =
- fun exp -> match exp.exp_desc with
- | Texp_let (_, _, e)
+ let classify_expression : Typedtree.expression -> sd =
+ (* We need to keep track of the size of expressions
+ bound by local declarations, to be able to predict
+ the size of variables. Compare:
+
+ let rec r =
+ let y = fun () -> r ()
+ in y
+
+ and
+
+ let rec r =
+ let y = if Random.bool () then ignore else fun () -> r ()
+ in y
+
+ In both cases the final adress of `r` must be known before `y` is compiled,
+ and this is only possible if `r` has a statically-known size.
+
+ The first definition can be allowed (`y` has a statically-known
+ size) but the second one is unsound (`y` has no statically-known size).
+ *)
+ let rec classify_expression env e = match e.exp_desc with
+ (* binding and variable cases *)
+ | Texp_let (rec_flag, vb, e) ->
+ let env = classify_value_bindings rec_flag env vb in
+ classify_expression env e
+ | Texp_ident (path, _, _) ->
+ classify_path env path
+
+ (* non-binding cases *)
| Texp_letmodule (_, _, _, e)
| Texp_sequence (_, e)
- | Texp_letexception (_, e) -> classify_expression e
- | Texp_ident _
+ | Texp_letexception (_, e) ->
+ classify_expression env e
+
+ | Texp_construct (_, {cstr_tag = Cstr_unboxed}, [e]) ->
+ classify_expression env e
+ | Texp_construct _ ->
+ Static
+
+ | Texp_record { representation = Record_unboxed _;
+ fields = [| _, Overridden (_,e) |] } ->
+ classify_expression env e
+ | Texp_record _ ->
+ Static
+
+ | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, _)
+ when is_ref vd ->
+ Static
+ | Texp_apply (_,args)
+ when List.exists is_abstracted_arg args ->
+ Static
+ | Texp_apply _ ->
+ Dynamic
+
| Texp_for _
| Texp_constant _
| Texp_new _
| Texp_instvar _
| Texp_tuple _
| Texp_array _
- | Texp_construct _
| Texp_variant _
- | Texp_record _
| Texp_setfield _
| Texp_while _
| Texp_setinstvar _
| Texp_function _
| Texp_lazy _
| Texp_unreachable
- | Texp_extension_constructor _ -> Static
- | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, _)
- when is_ref vd -> Static
- | Texp_apply _
+ | Texp_extension_constructor _ ->
+ Static
+
| Texp_match _
| Texp_ifthenelse _
| Texp_send _
| Texp_field _
| Texp_assert _
| Texp_try _
- | Texp_override _ -> Dynamic
+ | Texp_override _ ->
+ Dynamic
+ and classify_value_bindings rec_flag env bindings =
+ (* We use a non-recursive classification, classifying each
+ binding with respect to the old environment
+ (before all definitions), even if the bindings are recursive.
+
+ Note: computing a fixpoint in some way would be more
+ precise, as the following could be allowed:
+
+ let rec topdef =
+ let rec x = y and y = fun () -> topdef ()
+ in x
+ *)
+ ignore rec_flag;
+ let old_env = env in
+ let add_value_binding env vb =
+ match vb.vb_pat.pat_desc with
+ | Tpat_var (id, _loc) ->
+ let size = classify_expression old_env vb.vb_expr in
+ Ident.add id size env
+ | _ ->
+ (* Note: we don't try to compute any size for complex patterns *)
+ env
+ in
+ List.fold_left add_value_binding env bindings
+ and classify_path env = function
+ | Path.Pident x ->
+ begin
+ try Ident.find_same x env
+ with Not_found ->
+ (* an identifier will be missing from the map if either:
+ - it is a non-local identifier
+ (bound outside the letrec-binding we are analyzing)
+ - or it is bound by a complex (let p = e in ...) local binding
+ - or it is bound within a module (let module M = ... in ...)
+ that we are not traversing for size computation
+
+ For non-local identifiers it might be reasonable (although
+ not completely clear) to consider them Static (they have
+ already been evaluated), but for the others we must
+ under-approximate with Dynamic.
+
+ This could be fixed by a more complete implementation.
+ *)
+ Dynamic
+ end
+ | Path.Pdot _ | Path.Papply _ ->
+ (* local modules could have such paths to local definitions;
+ classify_expression could be extend to compute module
+ shapes more precisely *)
+ Dynamic
+ in classify_expression Ident.empty
let rec expression : Env.env -> Typedtree.expression -> Use.t =
fun env exp -> match exp.exp_desc with
(join
(inspect (expression env e1))
(inspect (expression env e2)))
- (* The body is evaluated, but not used, and not available
+ (* The body is evaluated, but not used, and not available
for inclusion in another value *)
(discard (expression env e3)))
| Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, [_, Some arg])
when is_ref vd ->
Use.guard (expression env arg)
- | Texp_apply (e, args) ->
- let arg env (_, eo) = option expression env eo in
- Use.(join
- (inspect (expression env e))
- (inspect (list arg env args)))
+ | Texp_apply (e, args) ->
+ let arg env (_, eo) = option expression env eo in
+ let ty = Use.join (list arg env args) (expression env e) in
+ if List.exists is_abstracted_arg args
+ then (* evaluate expressions, abstract over the results
+ let g = f and x = e in fun z -> g ~x z *)
+ Use.discard ty
+ else Use.inspect ty
| Texp_tuple exprs ->
Use.guard (list expression env exprs)
| Texp_array exprs when array_kind exp = `Pfloatarray ->
begin match Typeopt.classify_lazy_argument e with
| `Constant_or_function
| `Identifier _
- | `Float ->
+ | `Float_that_cannot_be_shortcut ->
expression env e
| `Other ->
Use.delay (expression env e)
else Use.discard ty (* as in 'let' *)
in
let vars = pattern_variables c_lhs in
- let env =
+ let env =
List.fold_left
(fun env id -> Ident.add id ty env)
env
fun rec_flag env bindings ->
match rec_flag with
| Recursive ->
- (* Approximation:
+ (* Approximation:
let rec y =
let rec x1 = e1
and x2 = e2
let ty = expression (build_unguarded_env idlist) expr in
match Use.unguarded ty, Use.dependent ty, classify_expression expr with
| _ :: _, _, _ (* The expression inspects rec-bound variables *)
- | _, _ :: _, Dynamic -> (* The expression depends on rec-bound variables
+ | _, _ :: _, Dynamic -> (* The expression depends on rec-bound variables
and its size is unknown *)
raise(Error(expr.exp_loc, env, Illegal_letrec_expr))
| [], _, Static (* The expression has known size *)
let ty = type_approx env e in
let ty1 = approx_type env sty in
begin try unify env ty ty1 with Unify trace ->
- raise(Error(sexp.pexp_loc, env, Expr_type_clash trace))
+ raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None)))
end;
ty1
| Pexp_coerce (e, sty1, sty2) ->
and ty1 = approx_ty_opt sty1
and ty2 = approx_type env sty2 in
begin try unify env ty ty1 with Unify trace ->
- raise(Error(sexp.pexp_loc, env, Expr_type_clash trace))
+ raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None)))
end;
ty2
| _ -> newvar ()
in
try loop p; false with Exit -> true
-let contains_gadt env p =
- let rec loop env p =
+let contains_gadt p =
+ let check p =
+ match p.pat_desc with
+ | Tpat_construct (_, cd, _) when cd.cstr_generalized ->
+ raise Exit
+ | _ -> ()
+ in
+ try iter_pattern check p; false with Exit -> true
+
+(* There are various things that we need to do in presence of GADT constructors
+ that aren't required if there are none.
+ However, because of disambiguation, we can't know for sure whether the
+ patterns contain some GADT constructors. So we conservatively assume that
+ any constructor might be a GADT constructor. *)
+let may_contain_gadts p =
+ let rec loop p =
match p.ppat_desc with
- | Ppat_construct (lid, _) ->
- begin try
- let cstrs = Env.lookup_all_constructors lid.txt env in
- List.iter (fun (cstr,_) -> if cstr.cstr_generalized then raise Exit)
- cstrs
- with Not_found -> ()
- end; iter_ppat (loop env) p
- | Ppat_open (lid,sub_p) ->
- let _, new_env = !type_open Asttypes.Override env p.ppat_loc lid in
- loop new_env sub_p
- | _ -> iter_ppat (loop env) p
+ | Ppat_construct (_, _) -> raise Exit
+ | _ -> iter_ppat loop p
in
- try loop env p; false with Exit -> true
+ try loop p; false with Exit -> true
let check_absent_variant env =
iter_pattern
let duplicate_ident_types caselist env =
let caselist =
- List.filter (fun {pc_lhs} -> contains_gadt env pc_lhs) caselist in
+ List.filter (fun {pc_lhs} -> may_contain_gadts pc_lhs) caselist in
Env.copy_types (all_idents_cases caselist) env
(* Getting proper location of already typed expressions.
let rec type_exp ?recarg env sexp =
(* We now delegate everything to type_expect *)
- type_expect ?recarg env sexp (newvar ())
+ type_expect ?recarg env sexp (mk_expected (newvar ()))
(* Typing of an expression with an expected type.
This provide better error messages, and allows controlled
In the principal case, [type_expected'] may be at generic_level.
*)
-and type_expect ?in_function ?recarg env sexp ty_expected =
+and type_expect ?in_function ?recarg env sexp ty_expected_explained =
let previous_saved_types = Cmt_format.get_saved_types () in
let exp =
Builtin_attributes.warning_scope sexp.pexp_attributes
(fun () ->
- type_expect_ ?in_function ?recarg env sexp ty_expected
+ type_expect_ ?in_function ?recarg env sexp ty_expected_explained
)
in
Cmt_format.set_saved_types
(Cmt_format.Partial_expression exp :: previous_saved_types);
exp
-and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
+and with_explanation explanation f =
+ match explanation with
+ | None -> f ()
+ | Some explanation ->
+ try f ()
+ with Error (loc', env', Expr_type_clash(trace', None))
+ when not loc'.Location.loc_ghost ->
+ raise (Error (loc', env', Expr_type_clash(trace', Some explanation)))
+
+and type_expect_
+ ?in_function ?(recarg=Rejected)
+ env sexp ty_expected_explained =
+ let { ty = ty_expected; explanation } = ty_expected_explained in
let loc = sexp.pexp_loc in
(* Record the expression type before unifying it with the expected type *)
+ let with_explanation = with_explanation explanation in
let rue exp =
- unify_exp env (re exp) (instance env ty_expected);
+ with_explanation (fun () ->
+ unify_exp env (re exp) (instance ty_expected));
exp
in
match sexp.pexp_desc with
Texp_ident(path, lid, desc)
end;
exp_loc = loc; exp_extra = [];
- exp_type = instance env desc.val_type;
+ exp_type = instance desc.val_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
end
if is_format then
let format_parsetree =
{ (type_format loc str env) with pexp_loc = sexp.pexp_loc } in
- type_expect ?in_function env format_parsetree ty_expected
+ type_expect ?in_function env format_parsetree ty_expected_explained
else
rue {
exp_desc = Texp_constant cst;
exp_env = env }
| Pexp_let(Nonrecursive,
[{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody)
- when contains_gadt env spat ->
+ when may_contain_gadts spat ->
(* TODO: allow non-empty attributes? *)
type_expect ?in_function env
{sexp with
pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
- ty_expected
+ ty_expected_explained
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
let scp =
match sexp.pexp_attributes, rec_flag with
let (pat_exp_list, new_env, unpacks) =
type_let env rec_flag spat_sexp_list scp true in
let body =
- type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in
+ type_expect new_env (wrap_unpacks sbody unpacks)
+ ty_expected_explained in
let () =
if rec_flag = Recursive then
check_recursive_bindings env pat_exp_list
Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",PStr []]
[Vb.mk spat smatch] sbody
in
- type_function ?in_function loc sexp.pexp_attributes env ty_expected
+ type_function ?in_function loc sexp.pexp_attributes env ty_expected_explained
l [Exp.case pat body]
| Pexp_fun (l, None, spat, sbody) ->
- type_function ?in_function loc sexp.pexp_attributes env ty_expected
+ type_function ?in_function loc sexp.pexp_attributes env ty_expected_explained
l [Ast_helper.Exp.case spat sbody]
| Pexp_function caselist ->
type_function ?in_function
- loc sexp.pexp_attributes env ty_expected Nolabel caselist
+ loc sexp.pexp_attributes env ty_expected_explained Nolabel caselist
| Pexp_apply(sfunct, sargs) ->
assert (sargs <> []);
begin_def (); (* one more level for non-returning functions *)
lower_args (ty::seen) ty_fun
| _ -> ()
in
- let ty = instance env funct.exp_type in
+ let ty = instance funct.exp_type in
end_def ();
wrap_trace_gadt_instances env (lower_args []) ty;
begin_def ();
re {
exp_desc = Texp_match(arg, val_cases, exn_cases, partial);
exp_loc = loc; exp_extra = [];
- exp_type = instance env ty_expected;
+ exp_type = instance ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_try(sbody, caselist) ->
- let body = type_expect env sbody ty_expected in
+ let body = type_expect env sbody ty_expected_explained in
let cases, _ =
type_cases env Predef.type_exn ty_expected false loc caselist in
re {
assert (List.length sexpl >= 2);
let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
let to_unify = newgenty (Ttuple subtypes) in
- unify_exp_types loc env to_unify ty_expected;
+ with_explanation (fun () ->
+ unify_exp_types loc env to_unify ty_expected);
let expl =
- List.map2 (fun body ty -> type_expect env body ty) sexpl subtypes
+ List.map2 (fun body ty -> type_expect env body (mk_expected ty))
+ sexpl subtypes
in
re {
exp_desc = Texp_tuple expl;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_construct(lid, sarg) ->
- type_construct env loc lid sarg ty_expected sexp.pexp_attributes
+ type_construct env loc lid sarg ty_expected_explained sexp.pexp_attributes
| Pexp_variant(l, sarg) ->
(* Keep sharing *)
- let ty_expected0 = instance env ty_expected in
+ let ty_expected0 = instance ty_expected in
begin try match
sarg, expand_head env ty_expected, expand_head env ty_expected0 with
| Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} ->
let decl = Env.find_type p' env in
begin_def ();
let ty =
- newconstr p' (instance_list env decl.type_params) in
+ newconstr p' (instance_list decl.type_params) in
end_def ();
generalize_structure ty;
ty, op
in
let closed = (opt_sexp = None) in
let lbl_exp_list =
- wrap_disambiguate "This record expression is expected to have" ty_record
+ wrap_disambiguate "This record expression is expected to have"
+ (mk_expected ty_record)
(type_label_a_list loc closed env
(fun e k -> k (type_label_exp true env loc ty_record e))
opath lid_sexp_list)
(fun x -> x)
in
- unify_exp_types loc env ty_record (instance env ty_expected);
+ with_explanation (fun () ->
+ unify_exp_types loc env ty_record (instance ty_expected));
(* type_label_a_list returns a list of labels sorted by lbl_pos *)
(* note: check_duplicates would better be implemented in
in
None, label_definitions
| Some exp ->
- let ty_exp = instance env exp.exp_type in
+ let ty_exp = instance exp.exp_type in
let unify_kept lbl =
let _, ty_arg1, ty_res1 = instance_label false lbl in
unify_exp_types exp.exp_loc env ty_exp ty_res1;
Overridden (lid, lbl_exp)
| exception Not_found -> begin
let _, ty_arg2, ty_res2 = instance_label false lbl in
- unify env ty_arg1 ty_arg2;
- unify env (instance env ty_expected) ty_res2;
+ unify_exp_types loc env ty_arg1 ty_arg2;
+ with_explanation (fun () ->
+ unify_exp_types loc env (instance ty_expected) ty_res2);
Kept ty_arg1
end
in
extended_expression = opt_exp
};
exp_loc = loc; exp_extra = [];
- exp_type = instance env ty_expected;
+ exp_type = instance ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_field(srecord, lid) ->
| Pexp_array(sargl) ->
let ty = newgenvar() in
let to_unify = Predef.type_array ty in
- unify_exp_types loc env to_unify ty_expected;
- let argl = List.map (fun sarg -> type_expect env sarg ty) sargl in
+ with_explanation (fun () ->
+ unify_exp_types loc env to_unify ty_expected);
+ let argl =
+ List.map (fun sarg -> type_expect env sarg (mk_expected ty)) sargl in
re {
exp_desc = Texp_array argl;
exp_loc = loc; exp_extra = [];
- exp_type = instance env ty_expected;
+ exp_type = instance ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_ifthenelse(scond, sifso, sifnot) ->
- let cond = type_expect env scond Predef.type_bool in
+ let cond = type_expect env scond
+ (mk_expected ~explanation:If_conditional Predef.type_bool) in
begin match sifnot with
None ->
- let ifso = type_expect env sifso Predef.type_unit in
+ let ifso = type_expect env sifso
+ (mk_expected ~explanation:If_no_else_branch Predef.type_unit) in
rue {
exp_desc = Texp_ifthenelse(cond, ifso, None);
exp_loc = loc; exp_extra = [];
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Some sifnot ->
- let ifso = type_expect env sifso ty_expected in
- let ifnot = type_expect env sifnot ty_expected in
+ let ifso = type_expect env sifso ty_expected_explained in
+ let ifnot = type_expect env sifnot ty_expected_explained in
(* Keep sharing *)
unify_exp env ifnot ifso.exp_type;
re {
exp_env = env }
end
| Pexp_sequence(sexp1, sexp2) ->
- let exp1 = type_statement env sexp1 in
- let exp2 = type_expect env sexp2 ty_expected in
+ let exp1 = type_statement ~explanation:Sequence_left_hand_side
+ env sexp1 in
+ let exp2 = type_expect env sexp2 ty_expected_explained in
re {
exp_desc = Texp_sequence(exp1, exp2);
exp_loc = loc; exp_extra = [];
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_while(scond, sbody) ->
- let cond = type_expect env scond Predef.type_bool in
- let body = type_statement env sbody in
+ let cond = type_expect env scond
+ (mk_expected ~explanation:While_loop_conditional Predef.type_bool) in
+ let body = type_statement ~explanation:While_loop_body env sbody in
rue {
exp_desc = Texp_while(cond, body);
exp_loc = loc; exp_extra = [];
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_for(param, slow, shigh, dir, sbody) ->
- let low = type_expect env slow Predef.type_int in
- let high = type_expect env shigh Predef.type_int in
+ let low = type_expect env slow
+ (mk_expected ~explanation:For_loop_start_index Predef.type_int) in
+ let high = type_expect env shigh
+ (mk_expected ~explanation:For_loop_stop_index Predef.type_int) in
let id, new_env =
match param.ppat_desc with
| Ppat_any -> Ident.create "_for", env
| _ ->
raise (Error (param.ppat_loc, env, Invalid_for_loop_index))
in
- let body = type_statement new_env sbody in
+ let body = type_statement ~explanation:For_loop_body new_env sbody in
rue {
exp_desc = Texp_for(id, param, low, high, dir, body);
exp_loc = loc; exp_extra = [];
if separate then begin
end_def ();
generalize_structure ty;
- (type_argument env sarg ty (instance env ty), instance env ty)
+ (type_argument env sarg ty (instance ty), instance ty)
end else
(type_argument env sarg ty ty, ty)
in
let tv = newvar () in
let gen = generalizable tv.level arg.exp_type in
(try unify_var env tv arg.exp_type with Unify trace ->
- raise(Error(arg.exp_loc, env, Expr_type_clash trace)));
+ raise(Error(arg.exp_loc, env, Expr_type_clash (trace, None))));
gen
end else true
in
end_def ();
generalize_structure ty;
generalize_structure ty';
- (type_argument env sarg ty (instance env ty),
- instance env ty', Some cty, cty')
+ (type_argument env sarg ty (instance ty),
+ instance ty', Some cty, cty')
end else
(type_argument env sarg ty ty, ty', Some cty, cty')
in
let method_type = newvar () in
let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in
unify env obj_ty desc.val_type;
- unify env res_ty (instance env typ);
+ unify env res_ty (instance typ);
let exp =
Texp_apply({exp_desc =
Texp_ident(Path.Pident method_id, lid,
let typ =
match repr typ with
{desc = Tpoly (ty, [])} ->
- instance env ty
+ instance ty
| {desc = Tpoly (ty, tl); level = l} ->
if !Clflags.principal && l <> generic_level then
Location.prerr_warning loc
match desc.val_kind with
Val_ivar (Mutable, cl_num) ->
let newval =
- type_expect env snewval (instance env desc.val_type) in
+ type_expect env snewval (mk_expected (instance desc.val_type))
+ in
let (path_self, _) =
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
in
let type_override (lab, snewval) =
begin try
let (id, _, _, ty) = Vars.find lab.txt !vars in
- (Path.Pident id, lab, type_expect env snewval (instance env ty))
+ (Path.Pident id, lab,
+ type_expect env snewval (mk_expected (instance ty)))
with
Not_found ->
let vars = Vars.fold (fun var _ li -> var::li) !vars [] in
Ident.set_current_time ty.level;
let context = Typetexp.narrow () in
let modl = !type_module env smodl in
+ Mtype.lower_nongen ty.level modl.mod_type;
let (id, new_env) = Env.enter_module name.txt modl.mod_type env in
Ctype.init_def(Ident.current_time());
Typetexp.widen context;
- let body = type_expect new_env sbody ty_expected in
+ let body = type_expect new_env sbody ty_expected_explained in
(* go back to original level *)
end_def ();
(* Unification of body.exp_type with the fresh variable ty
exp_env = env }
| Pexp_letexception(cd, sbody) ->
let (cd, newenv) = Typedecl.transl_exception env cd in
- let body = type_expect newenv sbody ty_expected in
+ let body = type_expect newenv sbody ty_expected_explained in
re {
exp_desc = Texp_letexception(cd, body);
exp_loc = loc; exp_extra = [];
exp_env = env }
| Pexp_assert (e) ->
- let cond = type_expect env e Predef.type_bool in
+ let cond = type_expect env e
+ (mk_expected ~explanation:Assert_condition Predef.type_bool) in
let exp_type =
match cond.exp_desc with
| Texp_construct(_, {cstr_name="false"}, _) ->
- instance env ty_expected
+ instance ty_expected
| _ ->
instance_def Predef.type_unit
in
| Pexp_lazy e ->
let ty = newgenvar () in
let to_unify = Predef.type_lazy_t ty in
- unify_exp_types loc env to_unify ty_expected;
- let arg = type_expect env e ty in
+ with_explanation (fun () ->
+ unify_exp_types loc env to_unify ty_expected);
+ let arg = type_expect env e (mk_expected ty) in
re {
exp_desc = Texp_lazy arg;
exp_loc = loc; exp_extra = [];
- exp_type = instance env ty_expected;
+ exp_type = instance ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env;
}
generalize_structure ty
end;
if sty <> None then
- unify_exp_types loc env (instance env ty) (instance env ty_expected);
+ with_explanation (fun () ->
+ unify_exp_types loc env (instance ty) (instance ty_expected));
let exp =
match (expand_head env ty).desc with
Tpoly (ty', []) ->
- let exp = type_expect env sbody ty' in
- { exp with exp_type = instance env ty }
+ let exp = type_expect env sbody (mk_expected ty') in
+ { exp with exp_type = instance ty }
| Tpoly (ty', tl) ->
(* One more level to generalize locally *)
begin_def ();
end_def ();
generalize_structure ty''
end;
- let exp = type_expect env sbody ty'' in
+ let exp = type_expect env sbody (mk_expected ty'') in
end_def ();
check_univars env false "method" exp ty_expected vars;
- { exp with exp_type = instance env ty }
+ { exp with exp_type = instance ty }
| Tvar _ ->
let exp = type_exp env sbody in
let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
(* remember original level *)
begin_def ();
(* Create a fake abstract type declaration for name. *)
- let level = get_current_level () in
let decl = {
type_params = [];
type_arity = 0;
type_private = Public;
type_manifest = None;
type_variance = [];
- type_newtype_level = Some (level, level);
+ type_is_newtype = true;
+ type_expansion_scope = None;
type_loc = loc;
type_attributes = [];
type_immediate = false;
(Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra }
| Pexp_pack m ->
let (p, nl) =
- match Ctype.expand_head env (instance env ty_expected) with
+ match Ctype.expand_head env (instance ty_expected) with
{desc = Tpackage (p, nl, _tl)} ->
if !Clflags.principal &&
(Ctype.expand_head env ty_expected).level < Btype.generic_level
exp_env = env }
| Pexp_open (ovf, lid, e) ->
let (path, newenv) = !type_open ovf env sexp.pexp_loc lid in
- let exp = type_expect newenv e ty_expected in
+ let exp = type_expect newenv e ty_expected_explained in
{ exp with
exp_extra = (Texp_open (ovf, path, lid, newenv), loc,
sexp.pexp_attributes) ::
| Pexp_unreachable ->
re { exp_desc = Texp_unreachable;
exp_loc = loc; exp_extra = [];
- exp_type = instance env ty_expected;
+ exp_type = instance ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
-and type_function ?in_function loc attrs env ty_expected l caselist =
+and type_function ?in_function loc attrs env ty_expected_explained l caselist =
+ let { ty = ty_expected; explanation } = ty_expected_explained in
let (loc_fun, ty_fun) =
match in_function with Some p -> p
- | None -> (loc, instance env ty_expected)
+ | None -> (loc, instance ty_expected)
in
let separate = !Clflags.principal || Env.has_local_constraints env in
if separate then begin_def ();
let (ty_arg, ty_res) =
- try filter_arrow env (instance env ty_expected) l
+ try filter_arrow env (instance ty_expected) l
with Unify _ ->
match expand_head env ty_expected with
{desc = Tarrow _} as ty ->
- raise(Error(loc, env, Abstract_wrong_label(l, ty)))
+ raise(Error(loc, env, Abstract_wrong_label(l, ty, explanation)))
| _ ->
raise(Error(loc_fun, env,
- Too_many_arguments (in_function <> None, ty_fun)))
+ Too_many_arguments (in_function <> None,
+ ty_fun,
+ explanation)))
in
let ty_arg =
if is_optional l then
re {
exp_desc = Texp_function { arg_label = l; param; cases; partial; };
exp_loc = loc; exp_extra = [];
- exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
+ exp_type = instance (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
exp_attributes = attrs;
exp_env = env }
let opath =
try
let (p0, p,_) = extract_concrete_record env ty_exp in
- Some(p0, p, ty_exp.level = generic_level || not !Clflags.principal)
+ Some(p0, p, (repr ty_exp).level = generic_level || not !Clflags.principal)
with Not_found -> None
in
let labels = Typetexp.find_all_labels env lid.loc lid.txt in
let label =
- wrap_disambiguate "This expression has" ty_exp
+ wrap_disambiguate "This expression has" (mk_expected ty_exp)
(Label.disambiguate lid env opath) labels in
(record, label, opath)
generalize_structure ty_res
end;
begin try
- unify env (instance_def ty_res) (instance env ty_expected)
+ unify env (instance_def ty_res) (instance ty_expected)
with Unify trace ->
raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace)))
end;
raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected)));
let arg =
let snap = if vars = [] then None else Some (Btype.snapshot ()) in
- let arg = type_argument env sarg ty_arg (instance env ty_arg) in
+ let arg = type_argument env sarg ty_arg (instance ty_arg) in
end_def ();
try
check_univars env (vars <> []) "field value" arg label.lbl_arg vars;
with Error (_, _, Less_general _) as e -> raise e
| _ -> raise exn (* In case of failure return the first error *)
in
- (lid, label, {arg with exp_type = instance env arg.exp_type})
+ (lid, label, {arg with exp_type = instance arg.exp_type})
and type_argument ?recarg env sarg ty_expected' ty_expected =
(* ty_expected' may be generic *)
let rec make_args args ty_fun =
match (expand_head env ty_fun).desc with
| Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
- let ty = option_none (instance env ty_arg) sarg.pexp_loc in
+ let ty = option_none (instance ty_arg) sarg.pexp_loc in
make_args ((l, Some ty) :: args) ty_fun
| Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic ->
List.rev args, ty_fun, no_labels ty_res'
let args, ty_fun', simple_res = make_args [] texp.exp_type in
let warn = !Clflags.principal &&
(lv <> generic_level || (repr ty_fun').level <> generic_level)
- and texp = {texp with exp_type = instance env texp.exp_type}
- and ty_fun = instance env ty_fun' in
+ and texp = {texp with exp_type = instance texp.exp_type}
+ and ty_fun = instance ty_fun' in
if not (simple_res || no_labels ty_res) then begin
unify_exp env texp ty_expected;
texp
func let_var) }
end
| _ ->
- let texp = type_expect ?recarg env sarg ty_expected' in
+ let texp = type_expect ?recarg env sarg (mk_expected ty_expected') in
unify_exp env texp ty_expected;
texp
(function l, None -> l, None
| l, Some f -> l, Some (f ()))
(List.rev args),
- instance env (result_type omitted ty_fun))
+ instance (result_type omitted ty_fun))
| (l1, sarg1) :: sargl ->
let (ty1, ty2) =
let ty_fun = expand_head env ty_fun in
in
let optional = is_optional l1 in
let arg1 () =
- let arg1 = type_expect env sarg1 ty1 in
+ let arg1 = type_expect env sarg1 (mk_expected ty1) in
if optional then
unify_exp env arg1 (type_option(newvar()));
arg1
may_warn funct.exp_loc
(Warnings.Without_principality "eliminated optional argument");
ignored := (l,ty,lv) :: !ignored;
- Some (fun () -> option_none (instance env ty) Location.none)
+ Some (fun () -> option_none (instance ty) Location.none)
end else begin
may_warn funct.exp_loc
(Warnings.Without_principality "commuted an argument");
let is_ignore funct =
match funct.exp_desc with
Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}) ->
- (try ignore (filter_arrow env (instance env funct.exp_type) Nolabel);
+ (try ignore (filter_arrow env (instance funct.exp_type) Nolabel);
true
with Unify _ -> false)
| _ -> false
(* Special case for ignore: avoid discarding warning *)
[Nolabel, sarg] when is_ignore funct ->
let ty_arg, ty_res =
- filter_arrow env (instance env funct.exp_type) Nolabel
+ filter_arrow env (instance funct.exp_type) Nolabel
in
- let exp = type_expect env sarg ty_arg in
+ let exp = type_expect env sarg (mk_expected ty_arg) in
begin match (expand_head env exp.exp_type).desc with
| Tarrow _ ->
Location.prerr_warning exp.exp_loc Warnings.Partial_application
| _ ->
let ty = funct.exp_type in
if ignore_labels then
- type_args [] [] ty (instance env ty) ty [] sargs
+ type_args [] [] ty (instance ty) ty [] sargs
else
- type_args [] [] ty (instance env ty) ty sargs []
+ type_args [] [] ty (instance ty) ty sargs []
-and type_construct env loc lid sarg ty_expected attrs =
+and type_construct env loc lid sarg ty_expected_explained attrs =
+ let { ty = ty_expected; explanation } = ty_expected_explained in
let opath =
try
let (p0, p,_) = extract_concrete_variant env ty_expected in
in
let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in
let constr =
- wrap_disambiguate "This variant expression is expected to have" ty_expected
+ wrap_disambiguate "This variant expression is expected to have"
+ ty_expected_explained
(Constructor.disambiguate lid env opath) constrs in
Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr;
Builtin_attributes.check_deprecated loc constr.cstr_attributes
if separate then begin
end_def ();
generalize_structure ty_res;
- unify_exp env {texp with exp_type = instance_def ty_res}
- (instance env ty_expected);
+ with_explanation explanation (fun () ->
+ unify_exp env {texp with exp_type = instance_def ty_res}
+ (instance ty_expected));
end_def ();
List.iter generalize_structure ty_args;
generalize_structure ty_res;
end;
let ty_args0, ty_res =
- match instance_list env (ty_res :: ty_args) with
+ match instance_list (ty_res :: ty_args) with
t :: tl -> tl, t
| _ -> assert false
in
let texp = {texp with exp_type = ty_res} in
- if not separate then unify_exp env texp (instance env ty_expected);
+ if not separate then unify_exp env texp (instance ty_expected);
let recarg =
match constr.cstr_inlined with
| None -> Rejected
(* Typing of statements (expressions whose values are discarded) *)
-and type_statement env sexp =
+and type_statement ?explanation env sexp =
let loc = (final_subexpression sexp).pexp_loc in
begin_def();
let exp = type_exp env sexp in
Location.prerr_warning loc Warnings.Nonreturning_statement;
if !Clflags.strict_sequence then
let expected_ty = instance_def Predef.type_unit in
- unify_exp env exp expected_ty;
+ with_explanation explanation (fun () ->
+ unify_exp env exp expected_ty);
exp
else begin
begin match ty.desc with
end
(* Typing of match cases *)
+and check_scope_escape loc env level ty =
+ try Ctype.check_scope_escape level ty
+ with Unify trace ->
+ raise(Error(loc, env, Pattern_type_clash(trace)))
and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
(* ty_arg is _fully_ generalized *)
let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
let contains_polyvars = List.exists contains_polymorphic_variant patterns in
- let erase_either = contains_polyvars && contains_variant_either ty_arg
- and has_gadts = List.exists (contains_gadt env) patterns in
-(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
+ let erase_either = contains_polyvars && contains_variant_either ty_arg in
+ let may_contain_gadts = List.exists may_contain_gadts patterns in
let ty_arg =
- if (has_gadts || erase_either) && not !Clflags.principal
+ if (may_contain_gadts || erase_either) && not !Clflags.principal
then correct_levels ty_arg else ty_arg
and ty_res, env =
- if has_gadts && not !Clflags.principal then
+ if may_contain_gadts && not !Clflags.principal then
correct_levels ty_res, duplicate_ident_types caselist env
else ty_res, env
in
| [{pc_lhs}] when is_var pc_lhs -> false
| _ -> true
in
+ let outer_level = get_current_level () in
let init_env () =
(* raise level for existentials *)
begin_def ();
Ident.set_current_time (get_current_level ());
let lev = Ident.current_time () in
- Ctype.init_def (lev+1000); (* up to 1000 existentials *)
- (lev, Env.add_gadt_instance_level lev env)
+ Ctype.init_def (lev+100000); (* up to 1000 existentials *)
+ lev
in
- let lev, env =
- if has_gadts then init_env () else (get_current_level (), env)
+ let lev =
+ if may_contain_gadts then init_env () else get_current_level ()
in
-(* if has_gadts then
- Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *)
(* Do we need to propagate polymorphism *)
let propagate =
- !Clflags.principal || has_gadts || (repr ty_arg).level = generic_level ||
+ !Clflags.principal || may_contain_gadts || (repr ty_arg).level = generic_level ||
match caselist with
[{pc_lhs}] when is_var pc_lhs -> false
| _ -> true in
+ let take_partial_instance =
+ if !Clflags.principal || erase_either
+ then Some false else None
+ in
if propagate then begin_def (); (* propagation of the argument *)
let pattern_force = ref [] in
(* Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
in
if !Clflags.principal then begin_def (); (* propagation of pattern *)
let scope = Some (Annot.Idef loc) in
+ begin_def ();
+ let ty_arg = instance ?partial:take_partial_instance ty_arg in
+ end_def ();
+ generalize_structure ty_arg;
+ let expected_ty_arg = instance ty_arg in
let (pat, ext_env, force, unpacks) =
- let partial =
- if !Clflags.principal || erase_either
- then Some false else None in
- let ty_arg = instance ?partial env ty_arg in
- type_pattern ~lev env pc_lhs scope ty_arg
+ type_pattern ~lev env pc_lhs scope expected_ty_arg
in
pattern_force := force @ !pattern_force;
let pat =
if !Clflags.principal then begin
end_def ();
iter_pattern (fun {pat_type=t} -> generalize_structure t) pat;
- { pat with pat_type = instance ext_env pat.pat_type }
+ { pat with pat_type = instance pat.pat_type }
end else pat
in
- (pat, (ext_env, unpacks)))
+ (* Ensure that no ambivalent pattern type escapes its branch *)
+ check_scope_escape pat.pat_loc env outer_level ty_arg;
+ (pat, ty_arg, (ext_env, unpacks)))
caselist in
(* Unify all cases (delayed to keep it order-free) *)
let ty_arg' = newvar () in
let unify_pats ty =
- List.iter (fun (pat, (ext_env, _)) -> unify_pat ext_env pat ty)
- pat_env_list in
+ List.iter (fun (pat, pat_ty, _) ->
+ unify_pat_types pat.pat_loc env pat_ty ty
+ ) pat_env_list
+ in
unify_pats ty_arg';
(* Check for polymorphic variants to close *)
- let patl = List.map fst pat_env_list in
+ let patl = List.map (fun (pat, _, _) -> pat) pat_env_list in
if List.exists has_variants patl then begin
Parmatch.pressure_variants env patl;
List.iter (iter_pattern finalize_variant) patl
(* `Contaminating' unifications start here *)
List.iter (fun f -> f()) !pattern_force;
(* Post-processing and generalization *)
- if propagate || erase_either then unify_pats (instance env ty_arg);
+ if take_partial_instance <> None then unify_pats (instance ty_arg);
if propagate then begin
List.iter
(iter_pattern (fun {pat_type=t} -> unify_var env t (newvar()))) patl;
end_def ();
+ generalize ty_arg';
List.iter (iter_pattern (fun {pat_type=t} -> generalize t)) patl;
end;
(* type bodies *)
let in_function = if List.length caselist = 1 then in_function else None in
let cases =
List.map2
- (fun (pat, (ext_env, unpacks)) {pc_lhs; pc_guard; pc_rhs} ->
+ (fun (pat, _, (ext_env, unpacks)) {pc_lhs = _; pc_guard; pc_rhs} ->
let sexp = wrap_unpacks pc_rhs unpacks in
let ty_res' =
if !Clflags.principal then begin
begin_def ();
- let ty = instance ~partial:true env ty_res in
+ let ty = instance ~partial:true ty_res in
end_def ();
generalize_structure ty; ty
end
- else if contains_gadt env pc_lhs then correct_levels ty_res
+ else if contains_gadt pat then correct_levels ty_res
else ty_res in
(* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
Printtyp.raw_type_expr ty_res'; *)
| Some scond ->
Some
(type_expect ext_env (wrap_unpacks scond unpacks)
- Predef.type_bool)
+ (mk_expected Predef.type_bool))
in
- let exp = type_expect ?in_function ext_env sexp ty_res' in
+ let exp =
+ type_expect ?in_function ext_env sexp (mk_expected ty_res') in
{
c_lhs = pat;
c_guard = guard;
- c_rhs = {exp with exp_type = instance env ty_res'}
+ c_rhs = {exp with exp_type = instance ty_res'}
}
)
pat_env_list caselist
in
- if !Clflags.principal || has_gadts then begin
- let ty_res' = instance env ty_res in
+ if !Clflags.principal || may_contain_gadts then begin
+ let ty_res' = instance ty_res in
List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
end;
- let do_init = has_gadts || needs_exhaust_check in
- let lev, env =
- if do_init && not has_gadts then init_env () else lev, env in
+ (* We could check whether there actually is a GADT here instead of reusing
+ [has_constructor], but I'm not sure it's worth it. *)
+ let do_init = may_contain_gadts || needs_exhaust_check in
+ let lev =
+ if do_init && not may_contain_gadts then init_env () else lev in
let ty_arg_check =
if do_init then
(* Hack: use for_saving to copy variables too *)
- Subst.type_expr (Subst.for_saving Subst.identity) ty_arg
- else ty_arg
+ Subst.type_expr (Subst.for_saving Subst.identity) ty_arg'
+ else ty_arg'
in
let partial =
if partial_flag then
- check_partial ~lev env ty_arg_check loc cases
+ check_partial ~lev env (instance ty_arg_check) loc cases
else
Partial
in
- let unused_check () =
- List.iter (fun (pat, (env, _)) -> check_absent_variant env pat)
+ let unused_check do_init =
+ let lev =
+ if do_init then init_env () else get_current_level ()
+ in
+ List.iter (fun (pat, _, (env, _)) -> check_absent_variant env pat)
pat_env_list;
- check_unused ~lev env (instance env ty_arg_check) cases ;
+ check_unused ~lev env (instance ty_arg_check) cases ;
+ if do_init then end_def ();
Parmatch.check_ambiguous_bindings cases
in
if contains_polyvars || do_init then
- add_delayed_check unused_check
+ add_delayed_check (fun () -> unused_check do_init)
else
- unused_check ();
+ unused_check false;
(* Check for unused cases, do not delay because of gadts *)
if do_init then begin
end_def ();
(* Ensure that existential types do not escape *)
- unify_exp_types loc env (instance env ty_res) (newvar ()) ;
+ unify_exp_types loc env (instance ty_res) (newvar ()) ;
end;
cases, partial
List.map
(fun pat ->
iter_pattern (fun pat -> generalize_structure pat.pat_type) pat;
- {pat with pat_type = instance env pat.pat_type})
+ {pat with pat_type = instance pat.pat_type})
pat_list
end else pat_list in
(* Only bind pattern variables after generalizing *)
slot := (name, vd) :: !slot; rec_needed := true
| None ->
List.iter
- (fun (name, vd) -> Env.mark_value_used env name vd)
+ (fun (name, vd) -> Env.mark_value_used name vd)
(get_ref slot);
used := true;
some_used := true
end;
let exp =
Builtin_attributes.warning_scope pvb_attributes
- (fun () -> type_expect exp_env sexp ty')
+ (fun () -> type_expect exp_env sexp (mk_expected ty'))
in
end_def ();
check_univars env true "definition" exp pat.pat_type vars;
- {exp with exp_type = instance env exp.exp_type}
+ {exp with exp_type = instance exp.exp_type}
| _ ->
Builtin_attributes.warning_scope pvb_attributes (fun () ->
- type_expect exp_env sexp pat.pat_type))
+ type_expect exp_env sexp (mk_expected pat.pat_type)))
spat_sexp_list pat_slot_list in
current_slot := None;
if is_recursive && not !rec_needed
l spat_sexp_list
in
if is_recursive then
- List.iter
+ List.iter
(fun {vb_pat=pat} -> match pat.pat_desc with
Tpat_var _ -> ()
| Tpat_alias ({pat_desc=Tpat_any}, _, _) -> ()
open Format
open Printtyp
+let report_type_expected_explanation expl ppf =
+ match expl with
+ | If_conditional ->
+ fprintf ppf "the condition of an if-statement"
+ | If_no_else_branch ->
+ fprintf ppf "the result of a conditional with no else branch"
+ | While_loop_conditional ->
+ fprintf ppf "the condition of a while-loop"
+ | While_loop_body ->
+ fprintf ppf "the body of a while-loop"
+ | For_loop_start_index ->
+ fprintf ppf "a for-loop start index"
+ | For_loop_stop_index ->
+ fprintf ppf "a for-loop stop index"
+ | For_loop_body ->
+ fprintf ppf "the body of a for-loop"
+ | Assert_condition ->
+ fprintf ppf "the condition of an assertion"
+ | Sequence_left_hand_side ->
+ fprintf ppf "the left-hand side of a sequence"
+
+let report_type_expected_explanation_opt expl ppf =
+ match expl with
+ | None -> ()
+ | Some expl ->
+ fprintf ppf "@ because it is in %t"
+ (report_type_expected_explanation expl)
+
let report_error env ppf = function
| Polymorphic_label lid ->
fprintf ppf "@[The record field %a is polymorphic.@ %s@]"
fprintf ppf "Variable %s must occur on both sides of this | pattern"
(Ident.name id);
spellcheck_idents ppf id valid_idents
- | Expr_type_clash trace ->
+ | Expr_type_clash (trace, explanation) ->
report_unification_error ppf env trace
+ ~type_expected_explanation:
+ (report_type_expected_explanation_opt explanation)
(function ppf ->
fprintf ppf "This expression has type")
(function ppf ->
print_labels labels
| Label_not_mutable lid ->
fprintf ppf "The record field %a is not mutable" longident lid
- | Wrong_name (eorp, ty, kind, p, name, valid_names) ->
+ | Wrong_name (eorp, ty_expected, kind, p, name, valid_names) ->
+ let { ty; explanation } = ty_expected in
reset_and_mark_loops ty;
if Path.is_constructor_typath p then begin
fprintf ppf "@[The field %s is not part of the record \
name
path p;
end else begin
- fprintf ppf "@[@[<2>%s type@ %a@]@ "
- eorp type_expr ty;
+ fprintf ppf "@[@[<2>%s type@ %a%t@]@ "
+ eorp type_expr ty
+ (report_type_expected_explanation_opt explanation);
fprintf ppf "The %s %s does not belong to type %a@]"
(label_of_kind kind)
name (*kind*) path p;
(function ppf ->
fprintf ppf "but is here used with type");
if b then
- fprintf ppf ".@.@[<hov>%s@ %s@]"
+ fprintf ppf ".@.@[<hov>%s@ %s@ %s@]"
"This simple coercion was not fully general."
- "Consider using a double coercion."
- | Too_many_arguments (in_function, ty) ->
+ "Hint: Consider using a fully explicit coercion"
+ "of the form: `(foo : ty1 :> ty2)'."
+ | Too_many_arguments (in_function, ty, explanation) ->
reset_and_mark_loops ty;
if in_function then begin
fprintf ppf "This function expects too many arguments,@ ";
- fprintf ppf "it should have type@ %a"
+ fprintf ppf "it should have type@ %a%t"
type_expr ty
+ (report_type_expected_explanation_opt explanation)
end else begin
fprintf ppf "This expression should not be a function,@ ";
- fprintf ppf "the expected type is@ %a"
+ fprintf ppf "the expected type is@ %a%t"
type_expr ty
+ (report_type_expected_explanation_opt explanation)
end
- | Abstract_wrong_label (l, ty) ->
+ | Abstract_wrong_label (l, ty, explanation) ->
let label_mark = function
| Nolabel -> "but its first argument is not labelled"
| l -> sprintf "but its first argument is labelled %s"
(prefixed_label_name l) in
reset_and_mark_loops ty;
- fprintf ppf "@[<v>@[<2>This function should have type@ %a@]@,%s@]"
- type_expr ty (label_mark l)
+ fprintf ppf "@[<v>@[<2>This function should have type@ %a%t@]@,%s@]"
+ type_expr ty
+ (report_type_expected_explanation_opt explanation)
+ (label_mark l)
| Scoping_let_module(id, ty) ->
reset_and_mark_loops ty;
fprintf ppf
| Unexpected_existential ->
fprintf ppf
"Unexpected existential"
- | Unqualified_gadt_pattern (tpath, name) ->
- fprintf ppf "@[The GADT constructor %s of type %a@ %s.@]"
- name path tpath
- "must be qualified in this pattern"
| Invalid_interval ->
fprintf ppf "@[Only character intervals are supported in patterns.@]"
| Invalid_for_loop_index ->
"@[%s@ %s@ %a@]"
"This match case could not be refuted."
"Here is an example of a value that would reach it:"
- Parmatch.top_pretty pat
+ Printpat.top_pretty pat
| Invalid_extension_constructor_payload ->
fprintf ppf
"Invalid [%%extension_constructor] payload, a constructor is expected."
"This kind of expression is not allowed as right-hand side of `let rec'"
| Illegal_class_expr ->
fprintf ppf "This kind of recursive class expression is not allowed"
+ | Empty_pattern -> assert false
let report_error env ppf err =
- wrap_printing_env env (fun () -> report_error env ppf err)
+ wrap_printing_env ~error:true env (fun () -> report_error env ppf err)
let () =
Location.register_error_of_exn
open Types
open Format
+(* This variant is used to print improved error messages, and does not affect
+ the behavior of the typechecker itself.
+
+ It describes possible explanation for types enforced by a keyword of the
+ language; e.g. "if" requires the condition to be of type bool, and the
+ then-branch to be of type unit if there is no else branch; "for" requires
+ indices to be of type int, and the body to be of type unit.
+*)
+type type_forcing_context =
+ | If_conditional
+ | If_no_else_branch
+ | While_loop_conditional
+ | While_loop_body
+ | For_loop_start_index
+ | For_loop_stop_index
+ | For_loop_body
+ | Assert_condition
+ | Sequence_left_hand_side
+
+(* The combination of a type and a "type forcing context". The intent is that it
+ describes a type that is "expected" (required) by the context. If unifying
+ with such a type fails, then the "explanation" field explains why it was
+ required, in order to display a more enlightening error message.
+*)
+type type_expected = private {
+ ty: type_expr;
+ explanation: type_forcing_context option;
+}
+
+val mk_expected:
+ ?explanation:type_forcing_context ->
+ type_expr ->
+ type_expected
+
val is_nonexpansive: Typedtree.expression -> bool
val type_binding:
Location.t -> Typedtree.case list -> Typedtree.partial
val type_expect:
?in_function:(Location.t * type_expr) ->
- Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression
+ Env.t -> Parsetree.expression -> type_expected -> Typedtree.expression
val type_exp:
Env.t -> Parsetree.expression -> Typedtree.expression
val type_approx:
| Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list
| Multiply_bound_variable of string
| Orpat_vars of Ident.t * Ident.t list
- | Expr_type_clash of (type_expr * type_expr) list
+ | Expr_type_clash of (type_expr * type_expr) list * type_forcing_context option
| Apply_non_function of type_expr
| Apply_wrong_label of arg_label * type_expr
| Label_multiply_defined of string
| Label_missing of Ident.t list
| Label_not_mutable of Longident.t
- | Wrong_name of string * type_expr * string * Path.t * string * string list
+ | Wrong_name of string * type_expected * string * Path.t * string * string list
| Name_type_mismatch of
string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
| Invalid_format of string
| Value_multiply_overridden of string
| Coercion_failure of
type_expr * type_expr * (type_expr * type_expr) list * bool
- | Too_many_arguments of bool * type_expr
- | Abstract_wrong_label of arg_label * type_expr
+ | Too_many_arguments of bool * type_expr * type_forcing_context option
+ | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option
| Scoping_let_module of string * type_expr
| Masked_instance_variable of Longident.t
| Not_a_variant_type of Longident.t
| Not_a_packed_module of type_expr
| Recursive_local_constraint of (type_expr * type_expr) list
| Unexpected_existential
- | Unqualified_gadt_pattern of Path.t * string
| Invalid_interval
| Invalid_for_loop_index
| No_value_clauses
| Illegal_letrec_pat
| Illegal_letrec_expr
| Illegal_class_expr
+ | Empty_pattern
exception Error of Location.t * Env.t * error
exception Error_forward of Location.error
begin match sdecl.ptype_manifest with None -> None
| Some _ -> Some(Ctype.newvar ()) end;
type_variance = List.map (fun _ -> Variance.full) sdecl.ptype_params;
- type_newtype_level = None;
+ type_is_newtype = false;
+ type_expansion_scope = None;
type_loc = sdecl.ptype_loc;
type_attributes = sdecl.ptype_attributes;
type_immediate = false;
| Tconstr (p, args, _) ->
begin match Env.find_type p env with
| exception Not_found -> Some ty
+ | {type_immediate = true; _} -> Some Predef.type_int
| {type_unboxed = {unboxed = false}} -> Some ty
| {type_params; type_kind =
Type_record ([{ld_type = ty2; _}], _)
| Type_variant [{cd_args = Cstr_tuple [ty2]; _}]
| Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}]}
- -> get_unboxed_type_representation env
- (Ctype.apply env type_params ty2 args) (fuel - 1)
+ ->
+ let ty2 = match ty2.desc with Tpoly (t, _) -> t | _ -> ty2 in
+ get_unboxed_type_representation env
+ (Ctype.apply env type_params ty2 args) (fuel - 1)
| {type_kind=Type_abstract} -> None
(* This case can occur when checking a recursive unboxed type
declaration. *)
match sdecl.ptype_kind with
| Ptype_abstract -> Ttype_abstract, Type_abstract
| Ptype_variant scstrs ->
- assert (scstrs <> []);
if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin
match cstrs with
[] -> ()
type_private = sdecl.ptype_private;
type_manifest = man;
type_variance = List.map (fun _ -> Variance.full) params;
- type_newtype_level = None;
+ type_is_newtype = false;
+ type_expansion_scope = None;
type_loc = sdecl.ptype_loc;
type_attributes = sdecl.ptype_attributes;
type_immediate = false;
then [Includecore.Constraint]
else
Includecore.type_declarations ~loc ~equality:true env
+ ~mark:true
(Path.last path)
decl'
id
match !current_slot with
| Some slot -> slot := (name, td) :: !slot
| None ->
- List.iter (fun (name, d) -> Env.mark_type_used env name d)
+ List.iter (fun (name, d) -> Env.mark_type_used name d)
(get_ref slot);
old_callback ()
);
let (args, cstr_res) = Ctype.instance_constructor cdescr in
let res, ret_type =
if cdescr.cstr_generalized then
- let params = Ctype.instance_list env type_params in
+ let params = Ctype.instance_list type_params in
let res = Ctype.newconstr type_path params in
let ret_type = Some (Ctype.newconstr type_path params) in
res, ret_type
let ttype_params = make_params env styext.ptyext_params in
let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in
List.iter2 (Ctype.unify_var env)
- (Ctype.instance_list env type_decl.type_params)
+ (Ctype.instance_list type_decl.type_params)
type_params;
let constructors =
List.map (transl_extension_constructor env type_path
(* Translate a "with" constraint -- much simplified version of
transl_type_decl. *)
let transl_with_constraint env id row_path orig_decl sdecl =
- Env.mark_type_used env (Ident.name id) orig_decl;
+ Env.mark_type_used (Ident.name id) orig_decl;
reset_type_variables();
Ctype.begin_def();
let tparams = make_params env sdecl.ptype_params in
type_private = priv;
type_manifest = man;
type_variance = [];
- type_newtype_level = None;
+ type_is_newtype = false;
+ type_expansion_scope = None;
type_loc = sdecl.ptype_loc;
type_attributes = sdecl.ptype_attributes;
type_immediate = false;
type_private = Public;
type_manifest = None;
type_variance = replicate_list Variance.full arity;
- type_newtype_level = None;
+ type_is_newtype = false;
+ type_expansion_scope = None;
type_loc = Location.none;
type_attributes = [];
type_immediate = false;
ignore (extract_sig_open env lid.loc md.md_type);
assert false
+let type_initially_opened_module env module_name =
+ let loc = Location.in_file "compiler internals" in
+ let lid = { Asttypes.loc; txt = Longident.Lident module_name } in
+ let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in
+ match Env.open_signature_of_initially_opened_module path env with
+ | Some env -> path, env
+ | None ->
+ let md = Env.find_module path env in
+ ignore (extract_sig_open env lid.loc md.md_type);
+ assert false
+
+let initial_env ~loc ~safe_string ~initially_opened_module
+ ~open_implicit_modules =
+ let env =
+ if safe_string then
+ Env.initial_safe_string
+ else
+ Env.initial_unsafe_string
+ in
+ let env =
+ match initially_opened_module with
+ | None -> env
+ | Some name ->
+ snd (type_initially_opened_module env name)
+ in
+ let open_implicit_module env m =
+ let open Asttypes in
+ let lid = {loc; txt = Longident.parse m } in
+ snd (type_open_ Override env lid.loc lid)
+ in
+ List.fold_left open_implicit_module env open_implicit_modules
+
let type_open ?toplevel env sod =
let (path, newenv) =
Builtin_attributes.warning_scope sod.popen_attributes
| Mty_functor (_, Some mty_param, _) -> mty_param
| _ -> assert false (* could trigger due to MPR#7611 *)
in
- let aliasable = not (Env.is_functor_arg arg env) in
- ignore(Includemod.modtypes ~loc env
- (Mtype.strengthen ~aliasable env mty_arg arg) mty_param)
+ Includemod.check_modtype_inclusion ~loc env mty_arg arg mty_param
(* When doing a deep destructive substitution with type M.N.t := .., we change M
and M.N and so we have to check that uses of the modules other than just
loop
;;
-let merge_constraint initial_env loc sg constr =
+let merge_constraint initial_env remove_aliases loc sg constr =
let lid =
match constr with
| Pwith_type (lid, _) | Pwith_module (lid, _)
)
sdecl.ptype_params;
type_loc = sdecl.ptype_loc;
- type_newtype_level = None;
+ type_is_newtype = false;
+ type_expansion_scope = None;
type_attributes = [];
type_immediate = false;
type_unboxed = unboxed_false_default_false;
| (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid'))
when Ident.name id = s ->
let path, md' = Typetexp.find_module initial_env loc lid'.txt in
- let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in
+ let mty = md'.md_type in
+ let mty = Mtype.scrape_for_type_of ~remove_aliases env mty in
+ let md'' = { md' with md_type = mty } in
let newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in
ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type);
(Pident id, lid, Twith_module (path, lid')),
| (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid'))
when Ident.name id = s ->
let path, md' = Typetexp.find_module initial_env loc lid'.txt in
- let newmd = Mtype.strengthen_decl ~aliasable:false env md' path in
+ let aliasable = not (Env.is_functor_arg path env) in
+ let newmd = Mtype.strengthen_decl ~aliasable env md' path in
ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type);
real_ids := [Pident id];
(Pident id, lid, Twith_modsubst (path, lid')),
let (sg, _) = aux sg in
sg
+let has_remove_aliases_attribute attr =
+ let remove_aliases =
+ Attr_helper.get_no_payload_attribute
+ ["remove_aliases"; "ocaml.remove_aliases"] attr
+ in
+ match remove_aliases with
+ | None -> false
+ | Some _ -> true
+
(* Check and translate a module type expression *)
let transl_modtype_longident loc env lid =
| Pmty_with(sbody, constraints) ->
let body = transl_modtype env sbody in
let init_sg = extract_sig env sbody.pmty_loc body.mty_type in
+ let remove_aliases = has_remove_aliases_attribute smty.pmty_attributes in
let (rev_tcstrs, final_sg) =
List.fold_left
(fun (rev_tcstrs,sg) sdecl ->
- let (tcstr, sg) = merge_constraint env smty.pmty_loc sg sdecl
+ let (tcstr, sg) =
+ merge_constraint env remove_aliases smty.pmty_loc sg sdecl
in
(tcstr :: rev_tcstrs, sg)
)
let id = info.typ_id in
let info' =
Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos))
- info.typ_type
+ id info.typ_type
in
Env.add_type ~check:true id info' e)
oldenv decls
let () = Ctype.package_subtype := package_subtype
-let wrap_constraint env arg mty explicit =
+let wrap_constraint env mark arg mty explicit =
+ let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in
let coercion =
try
- Includemod.modtypes ~loc:arg.mod_loc env arg.mod_type mty
+ Includemod.modtypes ~loc:arg.mod_loc env ~mark arg.mod_type mty
with Includemod.Error msg ->
raise(Error(arg.mod_loc, env, Not_included msg)) in
{ mod_desc = Tmod_constraint(arg, mty, explicit, coercion);
in
let sg' = simplify_signature sg in
if List.length sg' = List.length sg then md else
- wrap_constraint (Env.implicit_coercion env) md (Mty_signature sg')
+ wrap_constraint env false md (Mty_signature sg')
Tmodtype_implicit
| Pmod_functor(name, smty, sbody) ->
let mty = may_map (transl_modtype env) smty in
| Pmod_constraint(sarg, smty) ->
let arg = type_module ~alias true funct_body anchor env sarg in
let mty = transl_modtype env smty in
- rm {(wrap_constraint env arg mty.mty_type (Tmodtype_explicit mty)) with
+ let md =
+ wrap_constraint env true arg mty.mty_type (Tmodtype_explicit mty)
+ in
+ rm { md with
mod_loc = smod.pmod_loc;
mod_attributes = smod.pmod_attributes;
}
(* Extract the module type of a module expression *)
let type_module_type_of env smod =
+ let remove_aliases = has_remove_aliases_attribute smod.pmod_attributes in
let tmty =
match smod.pmod_desc with
| Pmod_ident lid -> (* turn off strengthening in this case *)
let path, md = Typetexp.find_module env smod.pmod_loc lid.txt in
- rm { mod_desc = Tmod_ident (path, lid);
- mod_type = md.md_type;
- mod_env = env;
- mod_attributes = smod.pmod_attributes;
- mod_loc = smod.pmod_loc }
- | _ -> type_module env smod in
+ rm { mod_desc = Tmod_ident (path, lid);
+ mod_type = md.md_type;
+ mod_env = env;
+ mod_attributes = smod.pmod_attributes;
+ mod_loc = smod.pmod_loc }
+ | _ -> type_module env smod
+ in
let mty = tmty.mod_type in
- (* PR#6307: expand aliases at root and submodules *)
- let mty = Mtype.remove_aliases env mty in
+ let mty = Mtype.scrape_for_type_of ~remove_aliases env mty in
(* PR#5036: must not contain non-generalized type variables *)
if not (closed_modtype env mty) then
raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));
(* go back to original level *)
Ctype.end_def ();
if nl = [] then
- (wrap_constraint env modl (Mty_ident p) Tmodtype_implicit, [])
+ (wrap_constraint env true modl (Mty_ident p) Tmodtype_implicit, [])
else let mty = modtype_of_package env modl.mod_loc p nl tl' in
List.iter2
(fun n ty ->
with Ctype.Unify _ ->
raise (Error(m.pmod_loc, env, Scoping_pack (n,ty))))
nl tl';
- (wrap_constraint env modl mty Tmodtype_implicit, tl')
+ (wrap_constraint env true modl mty Tmodtype_implicit, tl')
(* Fill in the forward declarations *)
let () =
let simple_sg = simplify_signature sg in
if !Clflags.print_types then begin
Typecore.force_delayed_checks ();
- Printtyp.wrap_printing_env initial_env
+ Printtyp.wrap_printing_env ~error:false initial_env
(fun () -> fprintf std_formatter "%a@." Printtyp.signature simple_sg);
(str, Tcoerce_none) (* result is ignored by Compile.implementation *)
end else begin
Interface_not_compiled sourceintf)) in
let dclsig = Env.read_signature modulename intf_file in
let coercion =
- Includemod.compunit initial_env sourcefile sg intf_file dclsig in
+ Includemod.compunit initial_env ~mark:Includemod.Mark_positive
+ sourcefile sg intf_file dclsig
+ in
Typecore.force_delayed_checks ();
(* It is important to run these checks after the inclusion test above,
so that value declarations which are not used internally but exported
(str, coercion)
end else begin
let coercion =
- Includemod.compunit initial_env sourcefile sg
- "(inferred signature)" simple_sg in
+ Includemod.compunit initial_env ~mark:Includemod.Mark_positive
+ sourcefile sg "(inferred signature)" simple_sg
+ in
check_nongen_schemes finalenv simple_sg;
normalize_signature finalenv simple_sg;
Typecore.force_delayed_checks ();
path p
let report_error env ppf err =
- Printtyp.wrap_printing_env env (fun () -> report_error ppf err)
+ Printtyp.wrap_printing_env ~error:true env (fun () -> report_error ppf err)
let () =
Location.register_error_of_exn
val check_nongen_schemes:
Env.t -> Types.signature -> unit
val type_open_:
- ?used_slot:bool ref -> ?toplevel:bool -> Asttypes.override_flag ->
+ ?used_slot:bool ref -> ?toplevel:bool ->
+ Asttypes.override_flag ->
Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t
val modtype_of_package:
Env.t -> Location.t ->
val package_units:
Env.t -> string list -> string -> string -> Typedtree.module_coercion
+(* Should be in Envaux, but it breaks the build of the debugger *)
+val initial_env:
+ loc:Location.t -> safe_string:bool ->
+ initially_opened_module:string option ->
+ open_implicit_modules:string list -> Env.t
+
type error =
Cannot_apply of module_type
| Not_included of Includemod.error list
| _ -> false
let maybe_pointer_type env ty =
+ let ty = scrape_ty env ty in
if Ctype.maybe_pointer_type env ty then
Pointer
else
let bigarray_decode_type env ty tbl dfl =
match scrape env ty with
| Tconstr(Pdot(Pident mod_id, type_name, _), [], _)
- when Ident.name mod_id = "CamlinternalBigarray" ->
+ when Ident.name mod_id = "Stdlib__bigarray" ->
begin try List.assoc type_name tbl with Not_found -> dfl end
| _ ->
dfl
taken into account when determining whether a recursive binding is safe. *)
let classify_lazy_argument : Typedtree.expression ->
[`Constant_or_function
- |`Float
+ |`Float_that_cannot_be_shortcut
|`Identifier of [`Forward_value|`Other]
|`Other] =
fun e -> match e.exp_desc with
| Texp_construct (_, {cstr_arity = 0}, _) ->
`Constant_or_function
| Texp_constant(Const_float _) ->
- `Float
+ if Config.flat_float_array
+ then `Float_that_cannot_be_shortcut
+ else `Constant_or_function
| Texp_ident _ when lazy_val_requires_forward e.exp_env e.exp_type ->
`Identifier `Forward_value
| Texp_ident _ ->
val classify_lazy_argument : Typedtree.expression ->
[ `Constant_or_function
- | `Float
+ | `Float_that_cannot_be_shortcut
| `Identifier of [`Forward_value | `Other]
| `Other]
type type_expr =
{ mutable desc: type_desc;
mutable level: int;
+ mutable scope: int option;
id: int }
and type_desc =
type_private: private_flag;
type_manifest: type_expr option;
type_variance: Variance.t list;
- type_newtype_level: (int * int) option;
+ type_is_newtype: bool;
+ type_expansion_scope: int option;
type_loc: Location.t;
type_attributes: Parsetree.attributes;
type_immediate: bool;
type type_expr =
{ mutable desc: type_desc;
mutable level: int;
+ mutable scope: int option;
id: int }
and type_desc =
[< `X | `Y > `X ] (row_closed = true)
type t = [> `X ] as 'a (row_more = Tvar a)
- type t = private [> `X ] (row_more = Tconstr (t#row, [], ref Mnil)
+ type t = private [> `X ] (row_more = Tconstr (t#row, [], ref Mnil))
And for:
type_manifest: type_expr option;
type_variance: Variance.t list;
(* covariant, contravariant, weakly contravariant, injective *)
- type_newtype_level: (int * int) option;
- (* definition level * expansion level *)
+ type_is_newtype: bool;
+ type_expansion_scope: int option;
type_loc: Location.t;
type_attributes: Parsetree.attributes;
type_immediate: bool; (* true iff type should not be a pointer *)
| Unbound_class of Longident.t
| Unbound_modtype of Longident.t
| Unbound_cltype of Longident.t
- | Ill_typed_functor_application of Longident.t
+ | Ill_typed_functor_application
+ of Longident.t * Longident.t * Includemod.error list option
| Illegal_reference_to_recursive_module
- | Access_functor_as_structure of Longident.t
- | Apply_structure_as_functor of Longident.t
+ | Wrong_use_of_module of Longident.t * [ `Structure_used_as_functor
+ | `Abstract_used_as_functor
+ | `Functor_used_as_structure
+ | `Abstract_used_as_structure
+ | `Generative_used_as_applicative
+ ]
| Cannot_scrape_alias of Longident.t * Path.t
| Opened_object of Path.t option
| Not_an_object of type_expr
type variable_context = int * (string, type_expr) Tbl.t
-(* Local definitions *)
-
-let instance_list = Ctype.instance_list Env.empty
-
(* Narrowing unbound identifier errors. *)
let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
| Env.Recmodule ->
raise (Error (loc, env, Illegal_reference_to_recursive_module))
in
+ let error e = raise (Error (loc, env, e)) in
begin match lid with
| Longident.Lident _ -> ()
| Longident.Ldot (mlid, _) ->
let md = Env.find_module (Env.lookup_module ~load:true mlid env) env in
begin match Env.scrape_alias env md.md_type with
| Mty_functor _ ->
- raise (Error (loc, env, Access_functor_as_structure mlid))
- | Mty_alias(_, p) ->
- raise (Error (loc, env, Cannot_scrape_alias(mlid, p)))
- | _ -> ()
+ error (Wrong_use_of_module (mlid, `Functor_used_as_structure))
+ | Mty_ident _ ->
+ error (Wrong_use_of_module (mlid, `Abstract_used_as_structure))
+ | Mty_alias(_, p) -> error (Cannot_scrape_alias(mlid, p))
+ | Mty_signature _ -> ()
end
| Longident.Lapply (flid, mlid) ->
check_module flid;
let fmd = Env.find_module (Env.lookup_module ~load:true flid env) env in
- begin match Env.scrape_alias env fmd.md_type with
- | Mty_signature _ ->
- raise (Error (loc, env, Apply_structure_as_functor flid))
- | Mty_alias(_, p) ->
- raise (Error (loc, env, Cannot_scrape_alias(flid, p)))
- | _ -> ()
- end;
+ let mty_param =
+ match Env.scrape_alias env fmd.md_type with
+ | Mty_signature _ ->
+ error (Wrong_use_of_module (flid, `Structure_used_as_functor))
+ | Mty_ident _ ->
+ error (Wrong_use_of_module (flid, `Abstract_used_as_functor))
+ | Mty_alias(_, p) -> error (Cannot_scrape_alias(flid, p))
+ | Mty_functor (_, None, _) ->
+ error (Wrong_use_of_module (flid, `Generative_used_as_applicative))
+ | Mty_functor (_, Some mty_param, _) -> mty_param
+ in
check_module mlid;
- let mmd = Env.find_module (Env.lookup_module ~load:true mlid env) env in
+ let mpath = Env.lookup_module ~load:true mlid env in
+ let mmd = Env.find_module mpath env in
begin match Env.scrape_alias env mmd.md_type with
- | Mty_alias(_, p) ->
- raise (Error (loc, env, Cannot_scrape_alias(mlid, p)))
- | _ ->
- raise (Error (loc, env, Ill_typed_functor_application lid))
+ | Mty_alias(_, p) -> error (Cannot_scrape_alias(mlid, p))
+ | mty_arg ->
+ let details =
+ try Includemod.check_modtype_inclusion
+ ~loc env mty_arg mpath mty_param;
+ None (* should be impossible *)
+ with Includemod.Error e -> Some e
+ in
+ error (Ill_typed_functor_application (flid, mlid, details))
end
end;
- raise (Error (loc, env, make_error lid))
+ error (make_error lid)
-let find_component (lookup : ?loc:_ -> _) make_error env loc lid =
+let find_component (lookup : ?loc:_ -> ?mark:_ -> _) make_error env loc lid =
try
match lid with
| Longident.Ldot (Longident.Lident "*predef*", s) ->
r
let lookup_module ?(load=false) env loc lid =
- find_component (fun ?loc lid env -> (Env.lookup_module ~load ?loc lid env))
+ find_component (fun ?loc ?mark lid env -> (Env.lookup_module ~load ?loc ?mark lid env))
(fun lid -> Unbound_module lid) env loc lid
let find_module env loc lid =
if name <> "" && name.[0] = '_' then
raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name)));
begin try
- instance env (List.assoc name !univars)
+ instance (List.assoc name !univars)
with Not_found -> try
- instance env (fst(Tbl.find name !used_variables))
+ instance (fst(Tbl.find name !used_variables))
with Not_found ->
let v =
if policy = Univars then new_pre_univar ~name () else newvar ~name ()
let t =
try List.assoc alias !univars
with Not_found ->
- instance env (fst(Tbl.find alias !used_variables))
+ instance (fst(Tbl.find alias !used_variables))
in
let ty = transl_type env policy st in
begin try unify_var env t ty.ctyp_type with Unify trace ->
end_def ();
generalize_structure t;
end;
- let t = instance env t in
+ let t = instance t in
let px = Btype.proxy t in
begin match px.desc with
| Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias)
in
make_fixed_univars typ.ctyp_type;
{ typ with ctyp_type =
- instance env (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) }
+ instance (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) }
let transl_simple_type_delayed env styp =
univars := []; used_variables := Tbl.empty;
| Present_has_no_type l ->
fprintf ppf "The present constructor %s has no type" l
| Constructor_mismatch (ty, ty') ->
- wrap_printing_env env (fun () ->
+ wrap_printing_env ~error:true env (fun () ->
Printtyp.reset_and_mark_loops_list [ty; ty'];
fprintf ppf "@[<hov>%s %a@ %s@ %a@]"
"This variant type contains a constructor"
| Multiple_constraints_on_type s ->
fprintf ppf "Multiple constraints for type %a" longident s
| Method_mismatch (l, ty, ty') ->
- wrap_printing_env env (fun () ->
+ wrap_printing_env ~error:true env (fun () ->
Printtyp.reset_and_mark_loops_list [ty; ty'];
fprintf ppf "@[<hov>Method '%s' has type %a,@ which should be %a@]"
l Printtyp.type_expr ty Printtyp.type_expr ty')
| Unbound_cltype lid ->
fprintf ppf "Unbound class type %a" longident lid;
spellcheck ppf fold_cltypes env lid;
- | Ill_typed_functor_application lid ->
- fprintf ppf "Ill-typed functor application %a" longident lid
+ | Ill_typed_functor_application (flid, mlid, details) ->
+ (match details with
+ | None ->
+ fprintf ppf "@[Ill-typed functor application %a(%a)@]"
+ longident flid longident mlid
+ | Some inclusion_error ->
+ fprintf ppf "@[The type of %a does not match %a's parameter@\n%a@]"
+ longident mlid longident flid Includemod.report_error inclusion_error)
| Illegal_reference_to_recursive_module ->
- fprintf ppf "Illegal recursive module reference"
- | Access_functor_as_structure lid ->
- fprintf ppf "The module %a is a functor, not a structure" longident lid
- | Apply_structure_as_functor lid ->
- fprintf ppf "The module %a is a structure, not a functor" longident lid
+ fprintf ppf "Illegal recursive module reference"
+ | Wrong_use_of_module (lid, details) ->
+ (match details with
+ | `Structure_used_as_functor ->
+ fprintf ppf "@[The module %a is a structure, it cannot be applied@]"
+ longident lid
+ | `Abstract_used_as_functor ->
+ fprintf ppf "@[The module %a is abstract, it cannot be applied@]"
+ longident lid
+ | `Functor_used_as_structure ->
+ fprintf ppf "@[The module %a is a functor, \
+ it cannot have any components@]" longident lid
+ | `Abstract_used_as_structure ->
+ fprintf ppf "@[The module %a is abstract, \
+ it cannot have any components@]" longident lid
+ | `Generative_used_as_applicative ->
+ fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \
+ applied@ in@ type@ expressions@]" longident lid)
| Cannot_scrape_alias(lid, p) ->
fprintf ppf
"The module %a is an alias for module %a, which is missing"
| Unbound_class of Longident.t
| Unbound_modtype of Longident.t
| Unbound_cltype of Longident.t
- | Ill_typed_functor_application of Longident.t
+ | Ill_typed_functor_application
+ of Longident.t * Longident.t * Includemod.error list option
| Illegal_reference_to_recursive_module
- | Access_functor_as_structure of Longident.t
- | Apply_structure_as_functor of Longident.t
+ | Wrong_use_of_module of Longident.t * [ `Structure_used_as_functor
+ | `Abstract_used_as_functor
+ | `Functor_used_as_structure
+ | `Abstract_used_as_structure
+ | `Generative_used_as_applicative
+ ]
| Cannot_scrape_alias of Longident.t * Path.t
| Opened_object of Path.t option
| Not_an_object of type_expr
let class_structure sub cs =
let rec remove_self = function
| { pat_desc = Tpat_alias (p, id, _s) }
- when string_is_prefix "selfpat-" id.Ident.name ->
+ when string_is_prefix "selfpat-" (Ident.name id) ->
remove_self p
| p -> p
in
--- /dev/null
+type path = string
+type path_prefix = string
+type error_message = string
+
+let errorf fmt = Printf.kprintf (fun err -> Error err) fmt
+
+let encode_prefix str =
+ let buf = Buffer.create (String.length str) in
+ let push_char = function
+ | '%' -> Buffer.add_string buf "%#"
+ | '=' -> Buffer.add_string buf "%+"
+ | ':' -> Buffer.add_string buf "%."
+ | c -> Buffer.add_char buf c
+ in
+ String.iter push_char str;
+ Buffer.contents buf
+
+let decode_prefix str =
+ let buf = Buffer.create (String.length str) in
+ let rec loop i =
+ if i >= String.length str
+ then Ok (Buffer.contents buf)
+ else match str.[i] with
+ | ('=' | ':') as c ->
+ errorf "invalid character '%c' in key or value" c
+ | '%' ->
+ let push c = Buffer.add_char buf c; loop (i + 2) in
+ if i + 1 = String.length str then
+ errorf "invalid encoded string %S (trailing '%%')" str
+ else begin match str.[i + 1] with
+ | '#' -> push '%'
+ | '+' -> push '='
+ | '.' -> push ':'
+ | c -> errorf "invalid %%-escaped character '%c'" c
+ end
+ | c ->
+ Buffer.add_char buf c;
+ loop (i + 1)
+ in loop 0
+
+type pair = { target: path_prefix; source : path_prefix }
+
+let encode_pair { target; source } =
+ String.concat "=" [encode_prefix target; encode_prefix source]
+
+let decode_pair str =
+ match String.index str '=' with
+ | exception Not_found ->
+ errorf "invalid key/value pair %S, no '=' separator" str
+ | equal_pos ->
+ let encoded_target = String.sub str 0 equal_pos in
+ let encoded_source =
+ String.sub str (equal_pos + 1) (String.length str - equal_pos - 1) in
+ match decode_prefix encoded_target, decode_prefix encoded_source with
+ | Ok target, Ok source -> Ok { target; source }
+ | ((Error _ as err), _) | (_, (Error _ as err)) -> err
+
+type map = pair option list
+
+let encode_map map =
+ let encode_elem = function
+ | None -> ""
+ | Some pair -> encode_pair pair
+ in
+ List.map encode_elem map
+ |> String.concat ":"
+
+let decode_map str =
+ let exception Shortcut of error_message in
+ let decode_or_empty = function
+ | "" -> None
+ | pair ->
+ begin match decode_pair pair with
+ | Ok str -> Some str
+ | Error err -> raise (Shortcut err)
+ end
+ in
+ let pairs = String.split_on_char ':' str in
+ match List.map decode_or_empty pairs with
+ | exception (Shortcut err) -> Error err
+ | map -> Ok map
+
+let rewrite_opt prefix_map path =
+ let is_prefix = function
+ | None -> false
+ | Some { target = _; source } ->
+ String.length source <= String.length path
+ && String.equal source (String.sub path 0 (String.length source))
+ in
+ match
+ List.find is_prefix
+ (* read key/value pairs from right to left, as the spec demands *)
+ (List.rev prefix_map)
+ with
+ | exception Not_found -> None
+ | None -> None
+ | Some { source; target } ->
+ Some (target ^ (String.sub path (String.length source)
+ (String.length path - String.length source)))
+
+let rewrite prefix_map path =
+ match rewrite_opt prefix_map path with
+ | None -> path
+ | Some path -> path
--- /dev/null
+type path = string
+type path_prefix = string
+type error_message = string
+
+val encode_prefix : path_prefix -> string
+val decode_prefix : string -> (path_prefix, error_message) result
+
+type pair = { target: path_prefix; source : path_prefix }
+
+val encode_pair : pair -> string
+val decode_pair : string -> (pair, error_message) result
+
+type map = pair option list
+
+val encode_map : map -> string
+val decode_map : string -> (map, error_message) result
+
+val rewrite_opt : map -> path -> path option
+(** [rewrite_opt map path] tries to find a source in [map]
+ that is a prefix of the input [path]. If it succeeds,
+ it replaces this prefix with the corresponding target.
+ If it fails, it just returns [None]. *)
+
+val rewrite : map -> path -> path
and error_size = ref 500 (* -error-size *)
and float_const_prop = ref true (* -no-float-const-prop *)
and transparent_modules = ref false (* -trans-mod *)
+let unique_ids = ref true
let dump_source = ref false (* -dsource *)
let dump_parsetree = ref false (* -dparsetree *)
and dump_typedtree = ref false (* -dtypedtree *)
let force_slash = ref false (* for ocamldep *)
let clambda_checks = ref false (* -clambda-checks *)
-let flambda_invariant_checks = ref true (* -flambda-invariants *)
+let flambda_invariant_checks =
+ ref Config.with_flambda_invariants (* -flambda-(no-)invariants *)
let dont_write_files = ref false (* set to true under ocamldoc *)
val error_size : int ref
val float_const_prop : bool ref
val transparent_modules : bool ref
+val unique_ids : bool ref
val dump_source : bool ref
val dump_parsetree : bool ref
val dump_typedtree : bool ref
val flambda : bool
(* Whether the compiler was configured for flambda *)
+val with_flambda_invariants : bool
+ (* Whether the invariants checks for flambda are enabled *)
val spacetime : bool
(* Whether the compiler was configured for Spacetime profiling *)
let profiling = %%PROFILING%%
let flambda = %%FLAMBDA%%
+let with_flambda_invariants = %%WITH_FLAMBDA_INVARIANTS%%
let safe_string = %%FORCE_SAFE_STRING%%
let default_safe_string = %%DEFAULT_SAFE_STRING%%
let windows_unicode = %%WINDOWS_UNICODE%% != 0
let afl_instrument = %%AFL_INSTRUMENT%%
-let exec_magic_number = "Caml1999X011"
-and cmi_magic_number = "Caml1999I022"
-and cmo_magic_number = "Caml1999O022"
-and cma_magic_number = "Caml1999A022"
+let exec_magic_number = "Caml1999X023"
+ (* exec_magic_number is duplicated in byterun/caml/exec.h *)
+and cmi_magic_number = "Caml1999I023"
+and cmo_magic_number = "Caml1999O023"
+and cma_magic_number = "Caml1999A023"
and cmx_magic_number =
if flambda then
- "Caml1999y022"
+ "Caml1999y023"
else
- "Caml1999Y022"
+ "Caml1999Y023"
and cmxa_magic_number =
if flambda then
- "Caml1999z022"
+ "Caml1999z023"
else
- "Caml1999Z022"
-and ast_impl_magic_number = "Caml1999M022"
-and ast_intf_magic_number = "Caml1999N022"
-and cmxs_magic_number = "Caml1999D022"
+ "Caml1999Z023"
+and ast_impl_magic_number = "Caml1999M023"
+and ast_intf_magic_number = "Caml1999N023"
+and cmxs_magic_number = "Caml1999D023"
(* cmxs_magic_number is duplicated in otherlibs/dynlink/natdynlink.ml *)
-and cmt_magic_number = "Caml1999T022"
+and cmt_magic_number = "Caml1999T023"
let load_path = ref ([] : string list)
let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0
-let no_overflow_mul a b = b <> 0 && (a * b) / b = a
+(* Taken from Hacker's Delight, chapter "Overflow Detection" *)
+let no_overflow_mul a b =
+ not ((a = min_int && b < 0) || (b <> 0 && (a * b) / b <> a))
let no_overflow_lsl a k =
0 <= k && k < Sys.word_size && min_int asr k <= a && a <= max_int asr k
(* *)
(* OCaml *)
(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* Xavier Leroy, projet Gallium, INRIA Paris *)
(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* Copyright 2017 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* *)
(**************************************************************************)
-(* Basic interface to the terminfo database *)
+open Printf
+
+external isatty : out_channel -> bool = "caml_sys_isatty"
+external terminfo_rows: out_channel -> int = "caml_terminfo_rows"
type status =
| Uninitialised
| Bad_term
- | Good_term of int
-;;
-external setup : out_channel -> status = "caml_terminfo_setup";;
-external backup : int -> unit = "caml_terminfo_backup";;
-external standout : bool -> unit = "caml_terminfo_standout";;
-external resume : int -> unit = "caml_terminfo_resume";;
+ | Good_term
+
+let setup oc =
+ let term = try Sys.getenv "TERM" with Not_found -> "" in
+ (* Same heuristics as in Misc.Color.should_enable_color *)
+ if term <> "" && term <> "dumb" && isatty oc
+ then Good_term
+ else Bad_term
+
+let num_lines oc =
+ let rows = terminfo_rows oc in
+ if rows > 0 then rows else 24
+ (* 24 is a reasonable default for an ANSI-style terminal *)
+
+let backup oc n =
+ if n >= 1 then fprintf oc "\027[%dA%!" n
+
+let resume oc n =
+ if n >= 1 then fprintf oc "\027[%dB%!" n
+
+let standout oc b =
+ output_string oc (if b then "\027[4m" else "\027[0m"); flush oc
type status =
| Uninitialised
| Bad_term
- | Good_term of int (* number of lines of the terminal *)
-;;
-external setup : out_channel -> status = "caml_terminfo_setup";;
-external backup : int -> unit = "caml_terminfo_backup";;
-external standout : bool -> unit = "caml_terminfo_standout";;
-external resume : int -> unit = "caml_terminfo_resume";;
+ | Good_term
+
+val setup : out_channel -> status
+val num_lines : out_channel -> int
+val backup : out_channel -> int -> unit
+val standout : out_channel -> bool -> unit
+val resume : out_channel -> int -> unit
let () = parse_options false defaults_w;;
let () = parse_options true defaults_warn_error;;
+let ref_manual_explanation () =
+ (* manual references are checked a posteriori by the manual
+ cross-reference consistency check in manual/tests*)
+ let[@manual.ref "s:comp-warnings"] chapter, section = 9, 5 in
+ Printf.sprintf "(See manual section %d.%d)" chapter section
+
let message = function
- | Comment_start -> "this is the start of a comment."
+ | Comment_start ->
+ "this `(*' is the start of a comment.\n\
+ Hint: Did you forget spaces when writing the infix operator `( * )'?"
| Comment_not_end -> "this is not the end of a comment."
| Deprecated (s, _, _) ->
(* Reduce \r\n to \n:
Printf.sprintf
"Code should not depend on the actual values of\n\
this constructor's arguments. They are only for information\n\
- and may change in future versions. (See manual section 8.5)"
+ and may change in future versions. %t" ref_manual_explanation
| Unreachable_case ->
"this match case is unreachable.\n\
Consider replacing it with a refutation case '<pat> -> .'"
"variables " ^ String.concat "," vars in
Printf.sprintf
"Ambiguous or-pattern variables under guard;\n\
- %s may match different arguments. (See manual section 8.5)"
- msg
+ %s may match different arguments. %t"
+ msg ref_manual_explanation
| No_cmx_file name ->
Printf.sprintf
"no cmx file was found in path for module %s, \
projects / ocaml.git / commitdiff
![manual/manual/htmlman/contents_motif.gif](/"http://www.example.com/cgi/"?p=ocaml.git;a=blob;f=manual/manual/htmlman/contents_motif.gif;h=5d3d016702478a74ae10ef900888bdd3c379aa3b;hb=27938ef6584aa9182ca144cdc7747c5e0ab61190){kind=link}
![manual/manual/htmlman/fonts/fira-sans-v8-latin-regular.svg](/"http://www.example.com/cgi/"?p=ocaml.git;a=blob;f=manual/manual/htmlman/fonts/fira-sans-v8-latin-regular.svg;h=1e520978debd2ac5c352a1a4c70422969e574210;hb=27938ef6584aa9182ca144cdc7747c5e0ab61190){kind=link}
![manual/manual/htmlman/libgraph.gif](/"http://www.example.com/cgi/"?p=ocaml.git;a=blob;f=manual/manual/htmlman/libgraph.gif;h=b385985b13d8f91851761f15db95b0e26f47f204;hb=27938ef6584aa9182ca144cdc7747c5e0ab61190){kind=link}
![manual/manual/htmlman/next_motif.gif](/"http://www.example.com/cgi/"?p=ocaml.git;a=blob;f=manual/manual/htmlman/next_motif.gif;h=3f84bacfb26ea6a4141ad407ff4fb77954171fea;hb=27938ef6584aa9182ca144cdc7747c5e0ab61190){kind=link}
![manual/manual/htmlman/previous_motif.gif](/"http://www.example.com/cgi/"?p=ocaml.git;a=blob;f=manual/manual/htmlman/previous_motif.gif;h=8c8a3e6430050e67e2e71dbd1f99fb9caf6176bf;hb=27938ef6584aa9182ca144cdc7747c5e0ab61190){kind=link}
![manual/manual/library/libgraph.png](/"http://www.example.com/cgi/"?p=ocaml.git;a=blob;f=manual/manual/library/libgraph.png;h=5841bfc805ca0a3a57a0881a218083157f947652;hb=27938ef6584aa9182ca144cdc7747c5e0ab61190){kind=link}
![+1,330](/"http://www.example.com/cgi/"?p=ocaml.git;a=blob;f=manual/manual/htmlman/fonts/fira-sans-v8-latin-regular.svg;h=1e520978debd2ac5c352a1a4c70422969e574210;hb=27938ef6584aa9182ca144cdc7747c5e0ab61190#l1){kind=link}